The following code is used for MPI parallel computing. The main purpose of the code is used to pack discontinuous data and scatter them averagely to other process.
for example:
In Zero process:
sendvar is a matrix, the size of it is 4 * 8, the data is below
| 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 |
| 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 |
| 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 |
| 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 |
the number of process is npros, npros=2
the start of dimension one s1=2, the end is e1=3 the start of dimension two s2=2 the end of dimension two e2=7
then the subroutine distribute sendvar(s1:e1,s2:e2) from 0 process to other process
after:
process=0 sendvar not changed
process=1 sendvar(s1:e1,4:5) is allocated and the data is :
| 14 | 15 |
| 24 | 25 |
process=2 sendvar(s1:e1,6:7) is allocated and the data is :
| 16 | 17 |
| 26 | 27 |
Code is below, all right reserved by Han Luo. Everybody could distribute and use it freely but obey GPL.
[fortran] SUBROUTINE DISTRIBUTE_VAR2(sendvar,s1,e1,s2,e2)
USE MPIINFO
include "mpif.h"
integer :: s1,e1,s2,e2
integer,allocatable :: sendvar(:,:)
integer :: dim1len,dim2len,pos,sendbuflen,reclen,ierr,yu
integer,allocatable :: sendcounts(:),displs(:),recbuf(:,:),sendbuf(:,:)
integer :: sv2s,sv2e,i,j !sendvar start and end for dim2
dim1len=e1-s1+1; dim2len=e2-s2+1
allocate(sendcounts(nprocs))
allocate(displs(nprocs))
if( myid .eq. 0)then
sendbuflen=dim1len*dim2len*4 !for integer, size=4 byte, thus sendbuflen
pos=0
!pack sendvar to continuous sendbuf
allocate(sendbuf(dim1len,dim2len))
do i=s2,e2
call MPI_PACK(sendvar(s1,i),dim1len,MPI_INTEGER,&
&sendbuf,sendbuflen,pos,MPI_COMM_WORLD,ierr)
end do
!calculate sendcounts
sendcounts=dim2len/nprocs
yu=mod(dim2len,nprocs)
if( yu .gt. 0)then
do i=1,yu
sendcounts(i)=sendcounts(i)+1
end do
end if
sendcounts=sendcounts*dim1len
!calculate displ
displs(1)=0
do i=2,nprocs
displs(i)=displs(i-1)+sendcounts(i-1)
end do
end if
call MPI_BCAST(sendcounts,nprocs,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
call MPI_BCAST(displs,nprocs,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
reclen=sendcounts(myid+1)
yu=reclen/dim1len
allocate(recbuf(dim1len,yu))
call MPI_SCATTERV(sendbuf,sendcounts,displs,MPI_INTEGER,&
&recbuf,reclen,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
if(myid .ne. 0)then
sv2s=s2+displs(myid+1)/dim1len
sv2e=sv2s+reclen/dim1len-1
allocate(sendvar(s1:e1,sv2s:sv2e))
pos=0
do i=1,reclen/dim1len
call MPI_UNPACK(recbuf,reclen*4,pos,&
&sendvar(s1,sv2s+i-1),dim1len,MPI_INTEGER,MPI_COMM_WORLD,ierr)
end do
else
deallocate(sendbuf)
end if
deallocate(recbuf,displs,sendcounts)
return
END SUBROUTINE[/fortran]