subroutine MAPL_CreateRequest(grid, Root, request, tag, RequestType, &
DstArray, PrePost, hw, rc)
type (ESMF_Grid), intent(IN ) :: grid
integer, intent(IN ) :: Root
type (MAPL_CommRequest), intent(INOUT) :: request
integer, intent(IN ) :: tag, RequestType
real, target, optional, intent(IN ) :: DstArray(:,:)
logical, optional, intent(IN ) :: PrePost
integer, optional, intent(IN ) :: hw
integer, optional, intent( OUT) :: rc
! Local variables
integer :: status
type (ESMF_VM) :: VM
type (ESMF_DistGrid) :: distGrid
integer, allocatable :: AL(:,:), AU(:,:)
integer :: count
integer :: displs
integer :: n
integer :: myPE, nDEs
integer :: gridRank
integer :: comm
integer :: hw_
! Begin
!------
if (present(hw)) then
hw_ = hw
else
hw_ = 0
end if
_ASSERT(.not.request%active, 'request is already active')
! Communicator info all comes from the ESMF VM
!---------------------------------------------
call ESMF_VMGetCurrent(vm, RC=STATUS)
_VERIFY(STATUS)
call ESMF_VMGet (VM, mpiCommunicator =comm, RC=STATUS)
_VERIFY(STATUS)
call ESMF_VMGet (VM, localpet=MYPE, petcount=nDEs, RC=STATUS)
_VERIFY(STATUS)
call ESMF_GridGet(GRID, dimCount=gridRank, rc=status)
_VERIFY(STATUS)
! Does not support 1D grids
!--------------------------
_ASSERT(gridRank > 1, 'rank 1 is not supported')
! Get the local grid bounds for all pes. We will use only
! the first 2 dimensions.
!--------------------------------------------------------
call ESMF_GridGet(GRID, distGrid=distGrid, RC=STATUS); _VERIFY(STATUS)
allocate (AL(gridRank,0:nDEs-1), stat=STATUS)
_VERIFY(STATUS)
allocate (AU(gridRank,0:nDEs-1), stat=STATUS)
_VERIFY(STATUS)
call MAPL_DistGridGet (distgrid, minIndex=AL, maxIndex=AU, RC=STATUS); _VERIFY(STATUS)
! Allocate space for request variables
!-------------------------------------
allocate (request%i1(0:nDEs-1), stat=STATUS)
_VERIFY(STATUS)
allocate (request%in(0:nDEs-1), stat=STATUS)
_VERIFY(STATUS)
allocate (request%j1(0:nDEs-1), stat=STATUS)
_VERIFY(STATUS)
allocate (request%jn(0:nDEs-1), stat=STATUS)
_VERIFY(STATUS)
allocate (request%im(0:nDEs-1), stat=STATUS)
_VERIFY(STATUS)
allocate (request%jm(0:nDEs-1), stat=STATUS)
_VERIFY(STATUS)
allocate (request%RECV (0:nDEs-1 ), stat=STATUS)
_VERIFY(STATUS)
allocate (request%SEND (0:nDEs-1 ), stat=STATUS)
_VERIFY(STATUS)
! Fill the request variables
!---------------------------
request%amRoot = (myPE == Root)
request%active = .true.
request%nDEs = nDEs
request%myPE = myPE
request%comm = comm
request%root = root
request%RequestType = RequestType
request%tag = tag
request%I1 = AL(1,:)-hw_
request%In = AU(1,:)+hw_
request%J1 = AL(2,:)-hw_
request%Jn = AU(2,:)+hw_
request%IM = request%IN-request%I1+1
request%JM = request%JN-request%J1+1
request%IM_WORLD = request%IN(nDEs-1)- request%I1(0) + 1 - (2*hw_)
request%JM_WORLD = request%JN(nDEs-1)- request%J1(0) + 1 - (2*hw_)
request%IM0 = request%IN(mype )- request%I1(mype) + 1
request%JM0 = request%JN(mype )- request%J1(mype) + 1
if(present(PrePost)) then
request%IsPrePosted = PrePost
else
request%IsPrePosted = .false.
end if
deallocate(AL,AU)
! Verify that we have a valid destination area
!---------------------------------------------
if(requestType==MAPL_IsGather) then
if(request%amRoot) then
if(present(DstArray)) then
request%DstArray => DstArray
_ASSERT(all(shape(DstArray)==(/ request%IM_WORLD, request%JM_WORLD/)), 'inconsistent shape')
else
allocate(request%DstArray(request%IM_WORLD, request%JM_WORLD),stat=STATUS)
_VERIFY(STATUS)
end if
endif
elseif(requestType==MAPL_IsScatter) then
if(present(DstArray)) then
request%DstArray => DstArray
_ASSERT(all(shape(DstArray)==(/ request%IM0 , request%JM0 /)), 'inconsistent shape')
else
allocate(request%DstArray(request%IM0 , request%JM0 ),stat=STATUS)
_VERIFY(STATUS)
end if
else
_FAIL( 'unsupported action')
end if
! Allocate a contiguous buffer for communication
!-----------------------------------------------
if(requestType==MAPL_IsGather .and. request%amRoot) then
allocate (request%Var(0:request%IM_WORLD*request%JM_WORLD-1), stat=STATUS)
_VERIFY(STATUS)
elseif(requestType==MAPL_IsScatter) then
allocate (request%Var(0:request%IM0*request%JM0-1), stat=STATUS)
_VERIFY(STATUS)
else
allocate (request%Var(1), stat=STATUS)
_VERIFY(STATUS)
endif
! We also PrePost the request here
!---------------------------------
POST_REQUEST: if(request%IsPrePosted) then
if(requestType==MAPL_IsGather) then
if(request%amRoot) then
displs = 0
do n=0,nDEs-1
count = request%IM(n)*request%JM(n)
if(n /= mype) then
call MPI_IRecv(request%VAR(displs), count, MPI_REAL, &
n, tag, comm, request%recv(n), status)
_VERIFY(STATUS)
end if
displs = displs + count
end do
endif
else
if(.not.request%amRoot) then
call MPI_IRecv(request%Var, size(request%Var), MPI_REAL, &
request%Root, tag, comm, request%recv(0), status)
_VERIFY(STATUS)
end if
end if
end if POST_REQUEST
_RETURN(ESMF_SUCCESS)
end subroutine MAPL_CreateRequest