function ESMF_LocStreamCreatePetList(locstream, name, petList, rc)
!
! !RETURN VALUE:
type(ESMF_LocStream) :: ESMF_LocStreamCreatePetList
!
! !ARGUMENTS:
type(ESMF_LocStream), intent(in) :: locstream
character (len=*), intent(in), optional :: name
integer, intent(in) :: petList(:)
integer, intent(out), optional :: rc
!
! !DESCRIPTION:
!
! Create an location stream from an existing one by moving entries
! between pets according to petList. Currently this is an internal
! subroutine not intended for public use.
!
! The arguments are:
! \begin{description}
! \item[locstream]
! Location stream from which the new location stream is to be created
! \item[{[name]}]
! Name of the resulting location stream
! \item[petList]
! Local list with the same number of entries as the number of entries on
! this Pet. Entries tell which pet to move the entry to an entry <0 says
! to not put the corresponding locstream entry into the new locstream.
! \item[{[rc]}]
! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
! \end{description}
!
!EOPI
type(ESMF_LocStreamType), pointer :: oldLStypep, newLStypep
type(ESMF_DistGrid) :: newDistGrid
type(ESMF_LocStream):: newLocStream
type(ESMF_VM) :: vm
type(ESMF_ArrayBundle) :: oldAB, newAB
type(ESMF_RouteHandle) :: routehandle
type(ESMF_TypeKind_Flag) ::keyTypeKind
character(len=ESMF_MAXSTR) :: keytemp, string
integer :: keyCount,i
integer :: localrc
integer :: lDE, localDECount
integer :: pos
integer, pointer :: seqInd(:)
integer :: seqCount, localPet, petCount
integer, pointer :: sndCounts(:),sndOffsets(:)
integer, pointer :: rcvCounts(:),rcvOffsets(:)
integer, pointer :: sndSizes(:)
integer, pointer :: rcvSizes(:)
integer, pointer :: sndPos(:)
integer :: newCount,tmp,petListCount, petInd
integer, pointer :: sndSeqInd(:), rcvSeqInd(:)
! Initialize return code; assume failure until success is certain
if (present(rc)) rc = ESMF_RC_NOT_IMPL
! Check Variables
ESMF_INIT_CHECK_DEEP(ESMF_LocStreamGetInit,locstream,rc)
! get size of petList
petListCount=size(petList)
! Get current VM
call ESMF_VMGetCurrent(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, localPet=localPet, petCount=petCount, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Allocate stuff for AllToAllV
allocate(sndCounts(petCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating sndCounts", &
ESMF_CONTEXT, rcToReturn=rc)) return
allocate(sndOffsets(petCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating sndOffsets", &
ESMF_CONTEXT, rcToReturn=rc)) return
allocate(rcvCounts(petCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating rcvCounts", &
ESMF_CONTEXT, rcToReturn=rc)) return
allocate(rcvOffsets(petCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating sndCounts", &
ESMF_CONTEXT, rcToReturn=rc)) return
! Allocate first set of buffers for commmunicating sizes
allocate(sndSizes(petCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating sndCounts", &
ESMF_CONTEXT, rcToReturn=rc)) return
allocate(rcvSizes(petCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating sndCounts", &
ESMF_CONTEXT, rcToReturn=rc)) return
! Count the number going to each Pet
sndSizes=0
do i=1,petListCount
petInd=petList(i)+1
if (petInd > 0) then
sndSizes(petInd)=sndSizes(petInd)+1
endif
enddo
! Number being sent
sndCounts=1
! Offset being sent
do i=1,petCount
sndOffsets(i)=i-1
enddo
! Number being sent
rcvCounts=1
! Offset being sent
do i=1,petCount
rcvOffsets(i)=i-1
enddo
! Communicate sizes being sent
call ESMF_VMAllToAllV(vm, sndSizes, sndCounts, sndOffsets, &
rcvSizes, rcvCounts, rcvOffsets, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Get sizes after communication
sndCounts=sndSizes
rcvCounts=rcvSizes
! Deallocate first set of buffers for commmunicating sizes
deallocate(sndSizes)
deallocate(rcvSizes)
! Get old locstream internal pointer
oldLStypep=>locstream%lstypep
! Allocate space for seqInd
allocate(seqInd(petListCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating seqInd", &
ESMF_CONTEXT, rcToReturn=rc)) return
! Get number of localDEs
call ESMF_LocStreamGet(locstream, localDECount=localDECount, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Loop getting seqIndices
pos=1
do lDE=0,localDECount-1
! Get number of seqIndices
call ESMF_DistGridGet(oldLStypep%distgrid, localDe=lDE, &
elementCount=seqCount, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Make sure we aren't going to overrun memory
if ((pos+seqCount-1) >petListCount) then
if (ESMF_LogFoundError(ESMF_RC_ARG_WRONG, &
msg=" - Too many seq indices in locstream disgrid", &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
! Get list of seqindices
call ESMF_DistGridGet(oldLStypep%distgrid, localDe=lDE, &
seqIndexList=seqInd(pos:pos+seqCount-1), rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! advance to next set of positions
pos=pos+seqCount
enddo
! Calculate Snd Offsets
sndOffsets(1)=0
do i=2,petCount
sndOffsets(i)=sndOffsets(i-1)+sndCounts(i-1)
enddo
! Calculate Rcv Offsets
rcvOffsets(1)=0
do i=2,petCount
rcvOffsets(i)=rcvOffsets(i-1)+rcvCounts(i-1)
enddo
! Allocate postions for seqInd data
allocate(sndPos(petCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating sndCounts", &
ESMF_CONTEXT, rcToReturn=rc)) return
! Allocate sndSeqInd
allocate(sndSeqInd(petListCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating sndSeqInd", &
ESMF_CONTEXT, rcToReturn=rc)) return
! Reset positions
sndPos=sndOffsets
! Copy seq indices into send buffer in correct order
do i=1,petListCount
petInd=petList(i)+1
if (petInd > 0) then
sndSeqInd(sndPos(petInd)+1)=seqInd(i)
sndPos(petInd)=sndPos(petInd)+1
endif
enddo
! deallocate seqInd
deallocate(seqInd)
! deallocate sndPos
deallocate(sndPos)
! Total size coming in
newCount=0
do i=1,petCount
newCount=newCount+rcvCounts(i)
enddo
! Allocate rcvSeqInd
allocate(rcvSeqInd(newCount), stat=localrc)
if (ESMF_LogFoundAllocError(localrc, msg="Allocating rcvSeqInd", &
ESMF_CONTEXT, rcToReturn=rc)) return
! Communicate sequence indices
call ESMF_VMAllToAllV(vm, sndSeqInd, sndCounts, sndOffsets, &
rcvSeqInd, rcvCounts, rcvOffsets, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Deallocate stuff for AllToAllV
deallocate(sndCounts)
deallocate(sndOffsets)
deallocate(rcvCounts)
deallocate(rcvOffsets)
! Deallocate sndSeqInd
deallocate(sndSeqInd)
! Create the new distgrid
newDistGrid=ESMF_DistGridCreate(arbSeqIndexList=rcvSeqInd, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Deallocate sndSeqInd
deallocate(rcvSeqInd)
! Create new locStream
ESMF_LocStreamCreatePetList=ESMF_LocStreamCreateFromNewDG(locstream, &
distgrid=newDistgrid, name=name, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Set distgrid to be destroyed, since ESMF created it
ESMF_LocStreamCreatePetList%lstypep%destroyDistgrid=.true.
! Return success
if (present(rc)) rc = ESMF_SUCCESS
end function ESMF_LocStreamCreatePetList