Segfault when passing data using MPI Windows (MPI_Put) - parallel-processing

I am trying to figure out how to use MPI to work with matrices.
I have a 3x6 matrix filled with zeros and am running code with 3 threads. 0 is the main one, 1 writes to the first row of the matrix in columns from 1 to 3 ones, and 2 stream writes to the second row in columns 4-6 of two.
I pass these formed parts to the main thread (at 0), I get the correct result, but after that a memory error is output to the console.
I can't figure out what I'm doing wrong. Can you please tell me what is my mistake?
program test
Use mpi
Implicit None
integer :: process_Rank, size_Of_Cluster, ierror = 0, win, size_s, n = 6
integer:: i , j
integer:: start, target_count = 9
integer :: mtx(3,6)
integer(kind = MPI_ADDRESS_KIND) :: nbytes = 4
!input matrix
do i = 1,3
do j =1,6
mtx(i,j) = 0
end do
end do
Call mpi_sizeof( mtx, size_s, ierror ) !Get the size of a matrix element
call MPI_INIT(ierror)
call MPI_COMM_SIZE(MPI_COMM_WORLD, size_Of_Cluster, ierror)
call MPI_COMM_RANK(MPI_COMM_WORLD, process_Rank, ierror)
!create windows
if(process_Rank == 0) then
call MPI_WIN_CREATE(mtx, size_s *6 * 3 * nbytes, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win, ierror)
else
call MPI_WIN_CREATE(mtx, size_s * 6* 3*nbytes,1, MPI_INFO_NULL, MPI_COMM_WORLD, win, ierror)
end if
CALL MPI_Win_fence(0,win,ierror)
if(process_Rank == 1) then
!fill 3 columns of the first row with ones
start = 0
do i = 0,3
mtx(process_Rank,i+start) = process_Rank
end do
CALL MPI_PUT(mtx, size_s*3*6, MPI_INTEGER, 0, start * nbytes, target_count, MPI_INTEGER, win, ierror)
!print mtx
print *, process_Rank, ' put = '
do i = 1,3
print *, ''
do j = 1,3
write(*,fmt='(g0)', advance = 'no') mtx(i,j)
write(*,fmt='(g0)', advance = 'no') ' '
end do
end do
end if
CALL MPI_Win_fence(0, win,ierror)
if(process_Rank == 2) then
!fill the last 3 columns of the second row with twos
start = 3
do i = 1,3
mtx(process_Rank,i+start) = process_Rank
end do
CALL MPI_PUT(mtx(1:3,4:6), size_s* 3 *6, MPI_INTEGER, 0, 3 * 3 * nbytes, target_count, MPI_INTEGER, win, ierror)
!print mtx
print *, process_Rank, ' put = '
do i = 1,3
print *, ''
do j = 4,6
write(*,fmt='(g0)', advance = 'no') mtx(i,j)
write(*,fmt='(g0)', advance = 'no') ' '
end do
end do
end if
CALL MPI_Win_fence(0, win,ierror)
! print result
if(process_Rank == 0) then
print *, 'result = '
do i = 1,3
print *, ''
do j = 1,6
write(*,fmt='(g0)', advance = 'no') mtx(i,j)
write(*,fmt='(g0)', advance = 'no') ' '
end do
end do
end if
CALL MPI_Win_fence(0, win,ierror)
CALL MPI_WIN_FREE(win, ierror)
call MPI_FINALIZE(ierror)
end program test
Console:
1 put =
1 1 1
0 0 0
0 0 0
2 put =
0 0 0
2 2 2
0 0 0
result =
1 1 1 0 0 0
0 0 0 2 2 2
0 0 0 0 0 0
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
#0 0x7fd4447bcd01 in ???
#1 0x7fd4447bbed5 in ???
#2 0x7fd4445f020f in ???
--------------------------------------------------------------------------
Primary job terminated normally, but 1 process returned
a non-zero exit code. Per user-direction, the job has been aborted.
--------------------------------------------------------------------------
--------------------------------------------------------------------------
mpirun noticed that process rank 0 with PID 0 on node alm-VirtualBox exited on signal 11 (Segmentation fault).
--------------------------------------------------------------------------

If you use the -fcheck=all, which Ian Bush suggested to you in the first comment under your question, you will get the reason for the error immediately and you do not have to wait many hours for feedback on the internet. I got:
At line 38 of file mpi_wins.f90 Fortran runtime error:
Index '0' of dimension 2 of array 'mtx' below lower bound of 1
Error termination. Backtrace:
#0 0x7f7ed3e75640 in ???
#1 0x7f7ed3e76185 in ???
#2 0x7f7ed3e7652a in ???
#3 0x4010e4 in test
at /home/lada/f/testy/stackoverflow/mpi_wins.f90:38
#4 0x401e78 in main
at /home/lada/f/testy/stackoverflow/mpi_wins.f90:3
You are indexing your mtx array using the process rank, but the array is defined to start from 1.
integer :: mtx(3,6)
However, MPI ranks start from 0, not from 1.
Also notice that the backtrace now contains a better code location thanks to the -g compiler option.

Related

MPI-IO MPI_INTEGER and MPI_DOUBLE_PRECISION give different results

The problem below is Write a 4 * 4 buff array using mpiio. I use 4 cores, so the subarray should be 2 * 2. The problem is that, when I set buff is integer(2,2), and set all the MPI_DOUBLE_PRECISION to MPI_INTEGER, the code works well. However, MPI_DOUBLE_PRECISION gives wrong results. It is strang becasue I don't think there are mistakes when I set the buff array.
Integer results::
0000000 1 1 1 1
0000016 1 1 1 1
0000032 1 1 1 1
0000048 1 1 1 1
0000064
Double Precision results::
0000000 0 1072693248 0 1072693248
0000016 0 1072693248 0 1072693248
0000032 0 1072693248 0 1072693248
0000048 0 1072693248 0 1072693248
0000064 0 1072693248 0 1072693248
0000080 0 1072693248 0 1072693248
0000096 0 1072693248 0 1072693248
0000112 0 1072693248 0 1072693248
0000128
This is the code:
program test
use mpi
implicit none
integer::rank,nproc,ierr,buffsize,status(MPI_STATUS_SIZE),intsize,i,j,filetype,cart_comm,count
integer::fh
integer(kind=mpi_offset_kind):: offset=0
double precision,dimension(2,2)::buff
character:: filename*50
integer::sizes(2)
integer::gsize(2)
integer::start(2)
integer::subsize(2)
integer::coords(2)
integer:: nprocs_cart(2)=(/2,2/)
logical::periods(2)
character:: name*50,para*100,zone*100
gsize=(/4,4/)
subsize=(/2,2/)
offset=0
buff=1.d0
count=1
call MPI_init(ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
CALL MPI_Dims_create(nproc, 2, nprocs_cart, ierr)
CALL MPI_Cart_create(MPI_COMM_WORLD, 2, nprocs_cart, periods, .TRUE., &
cart_comm, ierr)
CALL MPI_Comm_rank(cart_comm, rank, ierr)
CALL MPI_Cart_coords(cart_comm, rank, 2, coords, ierr)
start=coords*2
call MPI_TYPE_CREATE_SUBARRAY(2,gsize,subsize,start,MPI_ORDER_FORTRAN,&
MPI_DOUBLE_PRECISION,filetype,ierr)
call MPI_TYPE_COMMIT(filetype,ierr)
If( rank == 0 ) Then
Call mpi_file_delete( 'out.dat', MPI_INFO_NULL, ierr )
End If
Call mpi_barrier( mpi_comm_world, ierr )
call MPI_File_open(MPI_COMM_WORLD,'out.dat',&
MPI_MODE_WRONLY + MPI_MODE_CREATE, MPI_INFO_NULL, fh,ierr)
call MPI_File_set_view(fh,offset,MPI_DOUBLE_PRECISION,filetype,&
"native",MPI_INFO_NULL,ierr)
CALL MPI_FILE_WRITE_all(fh, buff,4, MPI_DOUBLE_PRECISION, MPI_STATUS_ignore, ierr)
call MPI_File_close(fh,ierr)
call MPI_FINALIZE(ierr)
end program test

How to pass information to the main process using MPI PUT?

I want to pass information to the main process using MPI PUT, but I get an error that the process exits without finalize.
For example, the error for two processes looks like this:
job aborted:
[ranks] message
[0] terminated
[1] process exited without calling finalize
How I can put my value 's' to main process? Can I do it with function MPI ACCUMULATE?
I want to get the modified s variable in the main process. What would the code look like if I wanted to calculate the sum of all received variables from all processes?
integer :: process_Rank, size_Of_Cluster, ierror = 0, win, s = 1
call MPI_INIT(ierror)
call MPI_COMM_SIZE(MPI_COMM_WORLD, size_Of_Cluster, ierror)
call MPI_COMM_RANK(MPI_COMM_WORLD, process_Rank, ierror)
!create windows
if(process_Rank == 0) then
call MPI_WIN_CREATE(s, sizeof(s), 1, MPI_INFO_NULL, MPI_COMM_WORLD, win, ierror)
else
call MPI_WIN_CREATE(0, 0, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win, ierror)
end if
print *, process_Rank, ' create window'
CALL MPI_Win_fence(0,win,ierror)
!get s from main process (rank = 0)
if(process_Rank <> 0) then
CALL MPI_Get(s, sizeof(s) , MPI_INT, 0, 0, 20, MPI_INT, win, ierror)
print *, process_Rank, ' get data and s = ', s
end if
CALL MPI_Win_fence(0,win,ierror)
if(process_Rank <> 0) then
s = s + process_Rank
print *, process_Rank, ' s = ', s
CALL MPI_PUT(s, sizeof(s), MPI_INT, 0 , 1 , 1, MPI_INT, win, ierror)
end if
print *, 'result s = ', s
CALL MPI_Win_fence(0, win,ierror)
CALL MPI_WIN_FREE(win, ierror)
call MPI_FINALIZE(ierror)
I'm sorry, but there was a lot wrong with your code and I don't have time to explain it all now, but below is a very quickly hacked together version that I think works - the main errors were incorrect kinds for actual arguments of MPI routines, and use of non-standard features (sizeof, <> [does that really work?], MPI_INT, maybe others). Please study it and try to work out why it works and yours does not, I shall try to come back and put in a longer explanation at some point. But if you learn nothing else stop using Include 'mpif.h' and start using the module as I have - this immediately caught one of your more serious errors, namely the wrong kind of integers for the displacement arguments in a number of calls.
If you are learning I would also recommend against the Portland Group compiler. My experiences with it over the years have not been good. Try and use a recent version of gfortran or the Intel or NAG compilers instead.
Program onesided
Use mpi
Implicit None
integer :: process_Rank, size_Of_Cluster, ierror = 0, win, s = 1, size_s
Call mpi_sizeof( s, size_s, ierror )
call MPI_INIT(ierror)
call MPI_COMM_SIZE(MPI_COMM_WORLD, size_Of_Cluster, ierror)
call MPI_COMM_RANK(MPI_COMM_WORLD, process_Rank, ierror)
!create windows
if(process_Rank == 0) then
call MPI_WIN_CREATE(s, Int( size_s, mpi_address_kind ), 1, MPI_INFO_NULL, MPI_COMM_WORLD, win, ierror)
else
call MPI_WIN_CREATE(0, 0_mpi_address_kind, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win, ierror)
end if
print *, process_Rank, ' create window'
CALL MPI_Win_fence(0,win,ierror)
!get s from main process (rank = 0)
if(process_Rank /= 0) then
CALL MPI_Get(s, 1, MPI_INTEGER, &
0, 0_mpi_address_kind, 1, MPI_INTEGER, win, ierror)
print *, process_Rank, ' get data and s = ', s
end if
CALL MPI_Win_fence(0,win,ierror)
if(process_Rank /= 0) then
s = s + process_Rank
print *, process_Rank, ' s = ', s
CALL MPI_PUT(s, 1, MPI_INTEGER, 0 , 0_mpi_address_kind, 1, MPI_INTEGER, win, ierror)
end if
print *, 'result s = ', s
CALL MPI_Win_fence(0, win,ierror)
CALL MPI_WIN_FREE(win, ierror)
call MPI_FINALIZE(ierror)
End Program onesided
ijb#ijb-Latitude-5410:~/work/stack$ mpif90 --version
GNU Fortran (Ubuntu 9.3.0-17ubuntu1~20.04) 9.3.0
Copyright (C) 2019 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
ijb#ijb-Latitude-5410:~/work/stack$ mpif90 -Wall -Wextra -fcheck=all -O -g -std=f2018 one_side.f90
ijb#ijb-Latitude-5410:~/work/stack$ mpirun -np 2 ./a.out
0 create window
result s = 1
1 create window
1 get data and s = 1
1 s = 2
result s = 2

Problem with using MPI_SENDRECV with 4 threads

As a minimal problem, I'm trying to send an integer between 4 processors: 0 -> 3 (rank 0 sends to and receives from rank 3), 2 -> 1, 1 -> 2, 3 -> 0. It never finishes execution and hangs, probably waiting for the response from other threads.
I'm compiling the code with mpif90 ... and running with mpiexec -np 4 .... Below is the minimal snippet:
program sendrecv
implicit none
include "mpif.h"
integer :: foo, bar
integer :: mpi_rank, mpi_size, ierr
integer :: mpi_sendto, mpi_recvfrom
integer :: istat(MPI_STATUS_SIZE), status, i
call MPI_INIT(ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, mpi_size, ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, mpi_rank, ierr)
print *, "SENDING..."
if (mpi_rank .eq. 0) then
mpi_sendto = 3; mpi_recvfrom = 3
else if (mpi_rank .eq. 1) then
mpi_sendto = 2; mpi_recvfrom = 2
else if (mpi_rank .eq. 2) then
mpi_sendto = 1; mpi_recvfrom = 1
else
mpi_sendto = 0; mpi_recvfrom = 0
end if
foo = mpi_rank
do i = 1, 5
foo = mpi_rank
call MPI_SENDRECV(foo, 1,&
& MPI_INTEGER, mpi_sendto, mpi_rank * 10 + i,&
& bar, 1,&
& MPI_INTEGER, mpi_recvfrom, mpi_rank * 10 + i,&
& MPI_COMM_WORLD, istat, ierr)
end do
print *, "...DONE"
call MPI_FINALIZE(ierr)
end
I don't really understand why this program hangs, maybe I'm missing something or doing something really wrong. If I understand correctly, MPI_SENDRECV is just non-blocking send and recv with two wait-s. In that case, say, if rank=0 sends to rank=3 it shouldn't have any problem receiving from it, right?
I tried sending/receiving from different threads, i.e., doing this:
if (mpi_rank .eq. 0) then
mpi_sendto = 1; mpi_recvfrom = 3
else if (mpi_rank .eq. 1) then
mpi_sendto = 2; mpi_recvfrom = 0
else if (mpi_rank .eq. 2) then
mpi_sendto = 3; mpi_recvfrom = 1
else
mpi_sendto = 0; mpi_recvfrom = 2
end if
still not working.
UPD As it was pointed out, tags should be the same when doing SENDRECV, however In case when doing this call within a loop, similar tags don't help much (see modified code). Old version:
call MPI_SENDRECV(foo, 1,&
& MPI_INTEGER, mpi_sendto, 200,&
& bar, 1,&
& MPI_INTEGER, mpi_recvfrom, 100,&
& MPI_COMM_WORLD, status, ierr)
UPD#2 Actually, if anyone is interested, I found a discussion exactly about the problem I have on why SENDRECV-s may deadlock sometimes.
The term "thread" is misleading here, you should talk about MPI task or MPI process (both are equivalent).
The root cause is a tag mismatch. You send with tag 200 but receive with tag 100.
Also, you should use istat instead of status as the status argument of MPI_Sendrecv().
Here is how you can fix your program
call MPI_SENDRECV(foo, 1,&
& MPI_INTEGER, mpi_sendto, 200,&
& bar, 1,&
& MPI_INTEGER, mpi_recvfrom, 200,&
& MPI_COMM_WORLD, istat, ierr)

MPI program for the Poisson equation stuck after one iteration

I am trying to solve the Poisson Equation in a Square domain [(0,1)--(0,1)] using MPI and overlapping domains. Currently, my code takes an input of the number of domain divisions on X and Y directions, the length of the overlap between two domains as a function of domain length and the number of elemntal divisions in the overlap.
Input file looks like
2,2
10,10
10,10
program main
!implicit none
include 'mpif.h'
integer cols, divfx, divfy, iter
integer xdiv, ydiv, info, max_iter, x_shift, y_shift
integer, allocatable:: ipiv(:)
double precision, allocatable :: A(:,:), Ainv(:,:)
real, allocatable:: edge(:,:)
double precision, allocatable :: u(:,:), f(:,:)
double precision, allocatable :: u_exact(:,:)
allocatable :: Left(:,:), Right(:,:)
allocatable :: Top(:,:), Bottom(:,:)
allocatable :: TempLeft(:,:), TempRight(:,:)
allocatable :: TempTop(:,:), TempBottom(:,:)
integer myid, master, numprocs, ierr, status(MPI_STATUS_SIZE)
integer i, j, numsent, sender, L, T, R, B
integer anstype, row, dovfx, dovfy, domx, domy, idx
real dom1,dom2,buff
double precision mesh(2), buffer(4), divx, divy, dx, dy, xd, yd
double precision error, derror, error_norm
character(len=100) :: domaindata
call MPI_INIT(ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
master = 0
divx=0.d0
divy=0.d0
! Input the number of divisions for domain decomposition and calculate sub-domain dimensions.
open(1, file='Inputdata.dat', status='old')
! read(1,*) domx,domy
! read(1,*) dovfx,dovfy
! read(1,*) divfx,divfy
write(*,*)'Starting the Program'
write(*,*) "Enter the number of domain divisions in x-direction &
and y-direction ( Enter 4 if you want three sub-domains)"
read(1,*) domx,domy
write(*,*) domx,domy
write(*,*) "Total number of sub-domains for the problem"
write(*,*) domx*domy
write(*,*) "Enter the sub-domain overlap in x & y -direction as &
a fraction of sub-domain length (multiple of 10)"
read(1,*) dovfx,dovfy
write(*,*) dovfx,dovfy
write(*,*) "Enter the number of divisions in the overlap in &
x & yas a fraction of sub-domain(multiple of 5)"
read(1,*) divfx,divfy
write(*,*) divfx,divfy
divx=1.d0/(((1.d0/domx)/dovfx)/divfx)
divy=1.d0/(((1.d0/domy)/dovfy)/divfy)
write(*,*)"Total number of elemental divisions for the &
problem domain (0,1) in both dimensions"
write(*,*) divx, divy, divx*divy
write(*,*)"Total number of nodal divisions for the problem domain"
write(*,*) (divx+1)*(divy+1)
! time
! **************************
tic = MPI_Wtime();
! Maximum number of iterations.
max_iter=100
! Mesh Size
mesh(1)=1/divx
mesh(2)=1/divy
write(*,*) 'Element Size'
write(*,*) mesh(1), mesh(2)
if ( myid .eq. master ) then
! Send iteration number to subdomain and receive the error from each to
! calculate total error.
write(*,*) 'still1'
do 10 iter = 1,max_iter
do 20 i = 1,domx*domy
call MPI_SEND(iter, 1, MPI_INTEGER, i, i, MPI_COMM_WORLD, ierr)
20 continue
! Receive results obtained from sub-processor/sub-domain
!
error = 0.d0
do 30 i = 1,domx*domy
call MPI_RECV(d_error , 1, MPI_DOUBLE_PRECISION, i, iter, &
MPI_COMM_WORLD, status, ierr)
error = error + d_error
30 continue
write(*,*) 'In iteration ', iter, 'cumulative error is', error*1.d0/domx/domy
10 continue
! time:
! *************
toc = MPI_Wtime();
! Write results to output
! **************************
write(*,*)
write(*,*) 'Time taken for parallel computation is: ',(toc-tic)*1000, 'miliseconds'
else
!************************************ Slaves receive mesh size for discretization ******************************************************
write(*,*) 'iter', iter
write(*,*) 'myid', myid
! Slaves receive corners, then creates a Cartesian grid for finite
! difference until done message received, for one iteration.
! This is done for the first iteration
! Get Domain ID :
if (myid.gt.(domx*domy)) goto 200
write(*,*) 'still31'
1000 call MPI_RECV(iter, 1, MPI_INTEGER, master, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
if (status(MPI_TAG) .eq. 0) goto 200
write(*,*) 'still4'
if (iter.eq.1) then
write(*,*) 'still5'
dom1=domx
dom2=domy
allocate (edge(domx*domy,4))
! Determining the edge matrices for each subdomain - the bounding box
do j =1,domx
do k=1,domy
idx=(j-1)*(domx-1)+k+(j-1)
buff=REAL((mod(idx-1,domx)))/domx
IF (buff-((1.d0/domx)/dovfx) .gt. 0) THEN
buff=buff-((1.d0/domx)/dovfx)
ENDIF
edge(idx,1) = buff
IF ((mod(idx ,domx)) .eq. 0) THEN
buff=1
ELSE
buff=REAL(mod(idx ,domx))/domx
ENDIF
!write(*,*) buff
IF (buff + ((1.d0/domx)/dovfx) .lt. 1) THEN
buff=buff+((1.d0/domx)/dovfx)
ENDIF
edge(idx,2) = buff
!
buff=REAL(floor((idx-1)/dom1))/dom1
IF (buff -((1.d0/domy)/dovfy) .gt. 0) THEN
buff=buff-((1.d0/domy)/dovfy)
ENDIF
edge(idx,3) = buff
buff=REAL(ceiling(idx/dom1))/dom1
IF (buff+((1.d0/domy)/dovfy) .lt. 1) THEN
buff= buff+((1.d0/domy)/dovfy)
ENDIF
edge(idx,4) = buff
end do
end do
write(*,*) myid, edge(myid,:)
write(*,*) 'iter', iter
call Surround_dom(myid,domx,domy,LeftC, RightC, BottomC, TopC)
! Calculate data for the matrices: Divisions in each subdomain. :
xdiv=(edge(myid,2)-edge(myid,1))/mesh(1)
ydiv=(edge(myid,4)-edge(myid,3))/mesh(2)
dx=mesh(1)
dy=mesh(2)
allocate (A((xdiv-1)*(ydiv-1),(xdiv-1)*(ydiv-1)))
allocate (Ainv((xdiv-1)*(ydiv-1),(xdiv-1)*(ydiv-1)))
allocate (u((xdiv-1)*(ydiv-1),1),f((xdiv-1)*(ydiv-1),1))
allocate (u_exact((xdiv-1)*(ydiv-1),1))
allocate (ipiv((xdiv-1)*(ydiv-1)))
allocate (Left((ydiv-1),1),Right((ydiv-1),1))
allocate (Top((xdiv-1),1), Bottom(((xdiv-1)),1))
allocate (TempLeft((ydiv-1),1),TempRight((ydiv-1),1))
allocate (TempTop((xdiv-1),1), TempBottom(((xdiv-1)),1))
Left = 0.d0; Right = 0.d0; Bottom = 0.d0; Top = 0.d0;
TempLeft = 0.d0; TempRight = 0.d0; TempBottom = 0.d0; TempTop = 0.d0;
A=0;
endif
write(*,*) 'still6'
! ******************************************************************
! SendReceive data based on location
! ******************************************************************
if (LeftC.ne.0) then
call MPI_SENDRECV(Left, ydiv - 1, MPI_DOUBLE_PRECISION, LeftC, iter, &
TempLeft, ydiv - 1, MPI_DOUBLE_PRECISION, LeftC, iter, MPI_COMM_WORLD, status, ierr)
end if
if (RightC.ne.0) then
call MPI_SENDRECV(Right, ydiv - 1, MPI_DOUBLE_PRECISION, RightC, iter, &
TempRight, ydiv - 1, MPI_DOUBLE_PRECISION, RightC, iter, MPI_COMM_WORLD, status, ierr)
end if
if (BottomC.ne.0) then
call MPI_SENDRECV(Bottom, xdiv - 1, MPI_DOUBLE_PRECISION, BottomC, iter, &
TempBottom, xdiv - 1, MPI_DOUBLE_PRECISION, BottomC, iter, MPI_COMM_WORLD, status, ierr)
end if
if (TopC.ne.0) then
call MPI_SENDRECV(Top, xdiv - 1, MPI_DOUBLE_PRECISION, TopC, iter, &
TempTop, xdiv - 1, MPI_DOUBLE_PRECISION, TopC, iter, MPI_COMM_WORLD, status, ierr)
end if
Left = TempLeft ;
Right = TempRight;
Top = TempTop ;
Bottom = TempBottom;
write(*,*) 'still7'
! Form the coefficient matrices
do i =1,(xdiv-1)*(ydiv-1)
A(i,i)=-2.d0*(1.d0/(dx**2)+1.d0/(dy**2))
enddo
do i=1,(xdiv-2)
do j=1,(ydiv-1)
A(i+(j-1)*(xdiv-1),i+(j-1)*(xdiv-1)+1)=1.d0/(dx**2)
A(i+(j-1)*(xdiv-1)+1,i+(j-1)*(xdiv-1))=1.d0/(dx**2)
enddo
enddo
do i=1,(xdiv-1)
do j=1,(ydiv-2)
A(i+(j-1)*(xdiv-1),i+(j)*(xdiv-1))=1.d0/(dy**2)
A(i+(j)*(xdiv-1),i+(j-1)*(xdiv-1))=1.d0/(dy**2)
enddo
enddo
write(*,*) 'still9'
L=1
T=1
R=1
B=1
write(*,*) 'still10'
! Impose Boundary Conditions in F matrix
do i=1,(xdiv-1)*(ydiv-1)
xd = edge(myid,1) + (dx)*mod(i,(xdiv-1))
if (mod(i,xdiv-1).eq.0) xd = edge(myid,1) + (dx)*(xdiv-1)
yd = edge(myid,3) + (dy)*ceiling(i*1.d0/(xdiv-1))
!if (iter.eq.1 .and. myid.eq.2) write(*,*) xd,yd
u_exact(i,1) = sin(2.d0*3.1415*xd)*sin(2.d0*3.1415*yd)
f(i,1) = 8.d0*3.1415*3.1415*u_exact(i,1)
IF (mod(i,(xdiv-1)) .eq. 1) THEN
f(i,1)= f(i,1)+Left(L,1)/dx/dx
L=L+1
ENDIF
IF (mod(i,(xdiv-1)) .eq. 0) THEN
f(i,1)=f(i,1)+Right(R,1)/dx/dx
R=R+1
ENDIF
IF (i .le. (xdiv-1)) THEN
f(i,1)=f(i,1)+Bottom(B,1)/dy/dy
B=B+1
ENDIF
IF (i .gt. (xdiv-1)*(ydiv-2)) THEN
f(i,1)=f(i,1)+Top(T,1)/dy/dy
T=T+1
END IF
! enddo
enddo
!Solve AU=F by LU factorization!
write(*,*) 'still11'
do i=1,(xdiv-1)*(ydiv-1)
do j=1,(xdiv-1)*(ydiv-1)
Ainv(i,j)=A(i,j)
end do
end do
! do i=1,(xdiv-1)*(ydiv-1)
! write(*,*) myid,Ainv(i,i)
!end do
call DGESV((xdiv-1)*(ydiv-1), 1, A, &
(xdiv-1)*(ydiv-1), ipiv, f, (xdiv-1)*(ydiv-1), info)
write(*,*) 'still12'
call ErrorNorm(f,u_exact,(xdiv-1)*(ydiv-1),error_norm)
write(*,*) 'still13'
! ****************************************************
! Update boundary conditions based on new solution:
! ****************************************************
x_shift = divfx-1 ;
y_shift = divfy-1 ;
! write(*,*) 'LeftC', myid,LeftC,RightC,TopC,BottomC
if (LeftC.ne.0) then
do 50 i = 1,ydiv - 1
Left(i,1) = f((xdiv - 1)*(i - 1) + 1 + x_shift,1)
!if ((myid.eq.2).and.(iter.eq.1)) write(*,*) 'for left',i, &
!(xdiv - 1)*(i - 1) + 1 + x_shift
50 continue
end if
if (RightC.ne.0) then
do 60 i = 1,ydiv - 1
Right(i,1) = f((xdiv - 1)*i - x_shift,1)
!if ((myid.eq.1).and.(iter.eq.1)) write(*,*) 'for right',i, &
!(xdiv - 1)*i - x_shift
60 continue
end if
if (TopC.ne.0) then
do 70 i = 1,xdiv - 1
Top(i,1) = f((xdiv - 1)*((ydiv - 2) - y_shift) + i,1)
!if ((myid.eq.1).and.(iter.eq.1)) write(*,*) 'for top',i, &
!((xdiv - 1)*((ydiv - 2) - y_shift) + i)
70 continue
end if
if ( BottomC.ne.0) then
do 80 i = 1,xdiv - 1
Bottom(i,1) = f((xdiv - 1)*y_shift + i,1)
!if ((myid.eq.3).and.(iter.eq.1)) write(*,*) 'for bottom',i, &
!((xdiv - 1)*y_shift + i)
80 continue
end if
write(*,*) 'still14'
TempLeft =Left;
TempRight = Right;
TempTop = Top;
TempBottom = Bottom;
call MPI_SEND(error_norm, 1, MPI_DOUBLE_PRECISION, master, iter, &
MPI_COMM_WORLD, ierr)
write(*,*) 'still15'
if (iter.lt.iter_max) go to 1000
! *********************************************************************************
! Write solution to data file to view the results.
! *********************************************************************************
write (domaindata, "(A7,I2,A4)") "domain_",myid,".dat"
open (unit=myid*10, file = domaindata)
write (myid*10,*) ' VARIABLE= "X","Y","U_EXACT","U_CALC" '
do i=1,(xdiv-1)*(ydiv-1)
xd = edge(myid,1) + (dx)*mod(i,(xdiv-1))
if (mod(i,xdiv-1).eq.0) xd = edge(myid,1) + (dx)*(xdiv-1)
yd = edge(myid,3) + (dy)*ceiling(i*1.d0/(xdiv-1))
write (myid*10,*) xd, yd, u_exact(i,1), f(i,1)
enddo
write(*,*) 'still16'
if (iter.eq.max_iter) go to 200
200 continue
write(*,*) 'still45'
endif
call MPI_FINALIZE(ierr)
stop
end program main
subroutine Surround_dom(myid,domx,domy,LeftID, RightID, BottomID, TopID)
implicit none
integer myid, j, k, domy, domx, BottomID, TopID, LeftID, RightID
j = ceiling(1.d0*myid/domx)
k = mod(myid,domx)
if (k.eq.0) k = domx
! Domain on the left
if(k.eq.1) then
LeftID = 0
else
LeftID = ((j-1)*domx + k) - 1
end if
! Domain on the Right
if(k.eq.domx) then
RightID = 0
else
RightID = ((j-1)*domx + k) + 1
end if
! Domain on the Bottom
if(j.eq.1) then
BottomID = 0
else
BottomID = ((j-1)*domx + k) - domx
end if
! Domain on the Top
if(j.eq.domy) then
TopID = 0
else
TopID = ((j-1)*domx + k) + domx
end if
return
end
subroutine ErrorNorm(u,u_exact,N,error_norm)
implicit none
double precision u(N), u_exact(N), err, error_norm
integer i, N
error_norm = 0.d0
do 10 i = 1,N
err = (u(i) - u_exact(i))
error_norm = error_norm + err*err
10 continue
error_norm = sqrt(error_norm)/(N*1.d0)
return
end
I expect the code to run through all the iterations giving me an respectable error about multiples of 1e-3/1e-4.?
Currently, no error shows up, the code successfully runs for 1 iteration and then doesn't produce any output at all, even after days. It would be really helpful if I could get some guidance. I am sorry since the structure of my code is a awkward, I am just a beginner. It won't run if number of domains is odd or if the number of domains is not equal to number of processors. Any suggestions on how to remove these limitations is also welcome.

MPI_BCAST() applied on only a fraction of the base group

I grouped 8 processors into two groups, each of which contains evenly four processors. I ask the root of each subgroup to do some communication with their subordinates using the subroutine "MPI_BCAST."
I came across a question: to indicate the root of a subgroup, should I use the original rank which the subgroup root corresponds to with the MPI_COMM_WORLD communicator, or the new rank it represents with the new communicator?
Take the code snippet below for example, I want to require P:0 to send data to its subordinates P:1, P:2, and P:3, and similarly, I ask P:4 to send out its data to P:5, P:6, P:7. To reach this goal, I am wondering if I should specify the fourth argument in line 36 as 1, or specify them as 0 and 4 respectively conditional on which head of subgroup I am referring to?
Thanks.
Lee
1 program main
2 include 'mpif.h'
3 integer :: ierr, irank, num_procs, base_group
4 integer :: nrow, ncol, irow, icol
5 integer :: dummy_group, dummy_comm, new_comm, new_rank
6 integer :: i, j, roster(4), data(4)
7
8 call MPI_Init ( ierr )
9 call MPI_COMM_RANK( MPI_comm_world, irank, ierr )
10 call MPI_COMM_SIZE( MPI_comm_world, num_procs, ierr)
11 call MPI_COMM_GROUP( MPI_comm_world, base_group, ierr)
12 nrow = 4
13 ncol = 2
14 irow = mod( irank, nrow ) + 1
15 icol = irank/nrow + 1
16
17 roster(1) = 0
18 do i = 2, nrow
19 roster(i) = roster(i-1) + 1
20 enddo
21
22 do i = 1, ncol
23 call MPI_GROUP_INCL( base_group, nrow, roster, dummy_group, ierr )
24 call MPI_COMM_CREATE( MPI_COMM_WORLD, dummy_group, dummy_comm, ierr )
25 if( icol == i ) new_comm = dummy_comm
26 forall( j=1:nrow ) roster(j) = roster(j) + nrow
27 enddo
28
29 ! Here I want to initialize data for processors P:0 and P:4
30 if( irank == 0 ) data = 0
31 if( irank == 4 ) data = 4
32
33 ! In the code below I want to require P:0 to send data to
34 ! its subordinates P:1, P:2, and P:3. Similarly, I ask P:4
35 ! to send out its data to P:5, P:6, P:7.
36 call MPI_BCAST( data, 4, MPI_INTEGER, 0, new_comm, ierr)
37
38 call MPI_Finalize ( ierr )
39 end program
All rank-type arguments (origin, target, etc.) in MPI must be ranks in the same communicator as that given by the communicator argument. In practice, what this means is that after creating a new communicator, each process in that communicator must call MPI_Comm_rank and MPI_Comm_size to retrieve it's rank and the total size in that communicator (unless you can deduce the new rank and size by other means in your code, of course).
As an aside, as what you're doing is splitting the original communicator into two disjoint communicators, I think an easier way to accomplish that is to use MPI_Comm_split rather than setting up groups manually as you have done.

Resources