Mach 6 Science
Life, Research, Music

[FORTRAN]Pack and scatterv for discontinuous data

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]

No comments yet

Comment