<p><b>dwj07@fsu.edu</b> 2012-05-18 15:13:12 -0600 (Fri, 18 May 2012)</p><p><br>
        -- BRANCH COMMIT --<br>
<br>
        New exchange list creation routine.<br>
        New all to all routines.<br>
        New halo exchange routines.<br>
<br>
        These new communication routines support local copies.<br>
        Mpas still doesn't run in this branch yet. But this is some initial work that needs to be done prior to creating blocks.<br>
</p><hr noshade><pre><font color="gray">Modified: branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar.F
===================================================================
--- branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar.F        2012-05-18 20:56:37 UTC (rev 1921)
+++ branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar.F        2012-05-18 21:13:12 UTC (rev 1922)
@@ -542,1922 +542,3398 @@
end subroutine mpas_dmpar_compute_index_range!}}}
- subroutine mpas_dmpar_get_owner_list(dminfo, &!{{{
- nOwnedList, nNeededList, &
- ownedList, neededList, &
- sendList, recvList, inOffset)
+ ! ----- NEW ROUTINES BELOW ----- !
+subroutine mpas_dmpar_get_exch_list(haloLayer, ownedListField, neededListField, offsetListField)!{{{
+
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nOwnedList, nNeededList
- integer, dimension(nOwnedList), intent(in) :: ownedList
- integer, dimension(nNeededList), intent(in) :: neededList
- type (exchange_list), pointer :: sendList
- type (exchange_list), pointer :: recvList
- integer, optional :: inOffset
+ integer, intent(in) :: haloLayer
+ type (field1dInteger), pointer :: ownedListField, neededListField
+ type (field0dInteger), pointer, optional :: offsetListField
- integer :: i, j, k, kk
+ type (dm_info), pointer :: dminfo
+
+ integer :: i, j, k, kk, iBlock
integer :: totalSize, nMesgRecv, nMesgSend, recvNeighbor, sendNeighbor, currentProc, offset
- integer :: numToSend, numToRecv
- integer, dimension(nOwnedList) :: recipientList
- integer, dimension(2,nOwnedList) :: ownedListSorted
+ integer :: totalSent, totalRecv
+ integer, allocatable, dimension(:) :: numToSend, numToRecv
+ integer, allocatable, dimension(:) :: ownedList, ownedListIndex, ownedBlock, neededList, neededListIndex, neededBlock
+ integer, allocatable, dimension(:) :: offsetList
+ integer, allocatable, dimension(:,:) :: ownedListSorted, ownedBlockSorted, recipientList
integer, allocatable, dimension(:) :: ownerListIn, ownerListOut
- type (exchange_list), pointer :: sendListPtr, recvListPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (field1dInteger), pointer :: fieldCursor, fieldCursor2
+ type (field0dInteger), pointer :: offsetCursor
+ integer :: nOwnedBlocks, nNeededBlocks
+ integer :: nOwnedList, nNeededList
integer :: mpi_ierr, mpi_rreq, mpi_sreq
+ !
+ ! *** NB: This code assumes that block % blockID values are local block IDs and are in the range [1, numBlocks]
+ ! where numBlocks is the number of blocks owned by each task
+ !
+
+
+ ! For the ownedListField:
+ ! - ownedList contains a list of the global indices owned by all blocks
+ ! - ownedListIndex contains a list of the block-local indices of the global indices owned by all blocks
+ ! - ownedBlock contains the local block ID associated with each index
+ !
+ ! Example:
+ ! ownedList := ( 21 13 15 01 05 06 33 42 44 45 ) ! Global indices from all blocks on this task
+ ! ownedListIndex := ( 1 2 3 4 1 2 3 4 5 6 ) ! Local indices of global indices on each block
+ ! ownedBlock := ( 1 1 1 1 2 2 2 2 2 2 ) ! Local indices of global indices on each block
+ !
+
+ ! For the neededListField:
+ ! similar to the owneListField...
+
+
+ !
+ ! Determine total number of owned indices on this task, and
+ ! initialize output send and recv lists for ownedListField
+ !
+
+ write(6,*) ' Setting up exchange lists'
+ dminfo => ownedListField % block % domain % dminfo
+
+ nOwnedList = 0
+ nOwnedBlocks = 0
+ fieldCursor => ownedListField
+ do while (associated(fieldCursor))
+ nOwnedBlocks = nOwnedBlocks + 1
+ nOwnedList = nOwnedList + fieldCursor % dimSizes(1)
+ fieldCursor => fieldCursor % next
+ end do
+
+
+ !
+ ! Determine total number of needed indices on this task
+ !
+ nNeededList = 0
+ nNeededBlocks = 0
+ fieldCursor => neededListField
+ do while (associated(fieldCursor))
+ nNeededBlocks = nNeededBlocks + 1
+ nNeededList = nNeededList + fieldCursor % dimSizes(1)
+ fieldCursor => fieldCursor % next
+ end do
+
#ifdef _MPI
- allocate(sendList)
- allocate(recvList)
- nullify(sendList % next)
- nullify(recvList % next)
- sendListPtr => sendList
- recvListPtr => recvList
+ !
+ ! Gather list of all owned indices and their associated blocks on this task
+ !
+ allocate(ownedList(nOwnedList))
+ allocate(ownedBlock(nOwnedList))
+ fieldCursor => ownedListField
+ i = 1
+ do while (associated(fieldCursor))
+ ownedList(i:i+fieldCursor % dimSizes(1)-1) = fieldCursor % array(:)
+ ownedBlock(i:i+fieldCursor % dimSizes(1)-1) = fieldCursor % block % localBlockID
+ i = i + fieldCursor % dimSizes(1)
+ fieldCursor => fieldCursor % next
+ end do
- offset = 0
- if(present(inOffset)) then
- offset = inOffset
- end if
-
+ !
+ ! Gather list of all needed indices and their associated blocks on this task
+ !
+ allocate(neededList(nNeededList))
+ allocate(neededBlock(nNeededList))
+ fieldCursor => neededListField
+ i = 1
+ do while (associated(fieldCursor))
+ neededList(i:i+fieldCursor % dimSizes(1)-1) = fieldCursor % array(:)
+ neededBlock(i:i+fieldCursor % dimSizes(1)-1) = fieldCursor % block % localBlockID
+ i = i + fieldCursor % dimSizes(1)
+ fieldCursor => fieldCursor % next
+ end do
+
+
+ !
+ ! Get list of index offsets for all blocks
+ !
+ allocate(offsetList(nNeededBlocks))
+ if (present(offsetListField)) then
+ offsetCursor => offsetListField
+ i = 0
+ do while (associated(offsetCursor))
+ i = i + 1
+ offsetList(i) = offsetCursor % scalar
+ offsetCursor => offsetCursor % next
+ end do
+ else
+ offsetList(:) = 0
+ end if
+
+
+ !
+ ! Obtain sorted list of global indices owned by this task and the associated local indices and block IDs
+ !
+ allocate(ownedListIndex(nOwnedList))
+ allocate(ownedListSorted(2,nOwnedList))
+ allocate(recipientList(2,nOwnedList))
+ j = 1
do i=1,nOwnedList
- ownedListSorted(1,i) = ownedList(i)
- ownedListSorted(2,i) = i
+ ownedListSorted(1,i) = ownedList(i)
+ if (i > 1) then
+ if(ownedBlock(i) /= ownedBlock(i-1)) j = 1
+ end if
+ ownedListIndex(i) = j
+ ownedListSorted(2,i) = j
+ j = j + 1
end do
call quicksort(nOwnedList, ownedListSorted)
+ allocate(ownedBlockSorted(2,nOwnedList))
+ do i=1,nOwnedList
+ ownedBlockSorted(1,i) = ownedList(i)
+ ownedBlockSorted(2,i) = ownedBlock(i)
+ end do
+ call quicksort(nOwnedList, ownedBlockSorted)
+
+
+ allocate(neededListIndex(nOwnedList))
+ j = 1
+ do i=1,nNeededList
+ if (i > 1) then
+ if(neededBlock(i) /= neededBlock(i-1)) j = 1
+ end if
+ neededListIndex(i) = j
+ j = j + 1
+ end do
+
+
+ !
+ ! Set totalSize to the maximum number of items in any task's needed list
+ !
call MPI_Allreduce(nNeededList, totalSize, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
allocate(ownerListIn(totalSize))
allocate(ownerListOut(totalSize))
nMesgRecv = nNeededList
+ nMesgSend = nMesgRecv
ownerListIn(1:nNeededList) = neededList(1:nNeededList)
recvNeighbor = mod(dminfo % my_proc_id + dminfo % nprocs - 1, dminfo % nprocs)
sendNeighbor = mod(dminfo % my_proc_id + 1, dminfo % nprocs)
- do i=1, dminfo % nprocs
+ allocate(numToSend(nOwnedBlocks))
+ allocate(numToRecv(nNeededBlocks))
- recipientList(:) = -1
- numToSend = 0
+ write(6,*) ' First send/recvs'
+ ! Initial send of data to neighbors.
+ call MPI_Irecv(nMesgRecv, 1, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(nMesgSend, 1, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Irecv(ownerListIn, nMesgRecv, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(ownerListOut, nMesgSend, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
- currentProc = mod(dminfo % my_proc_id + dminfo % nprocs - i + 1, dminfo % nprocs)
- do j=1,nMesgRecv
- if (ownerListIn(j) > 0) then
- k = mpas_binary_search(ownedListSorted, 2, 1, nOwnedList, ownerListIn(j))
- if (k <= nOwnedList) then
- ownerListOut(j) = -1 * dminfo % my_proc_id
- numToSend = numToSend + 1
- recipientList(ownedListSorted(2,k)) = numToSend
- else
- ownerListOut(j) = ownerListIn(j)
- end if
+ !
+ ! For each processor (including ourself), mark the indices that we will provide to
+ ! that processor in ownerListOut, and build a send list for that processor if we
+ ! do need to send any indices
+ !
+ write(6,*) 'i loop'
+ do i=2, dminfo % nprocs
+ recipientList = -1
+ numToSend(:) = 0
+ totalSent = 0
+
+ currentProc = mod(dminfo % my_proc_id + dminfo % nprocs - i + 1, dminfo % nprocs)
+ do j=1,nMesgRecv
+ if (ownerListIn(j) > 0) then
+ k = mpas_binary_search(ownedListSorted, 2, 1, nOwnedList, ownerListIn(j))
+ if (k <= nOwnedList) then
+ ownerListOut(j) = -1 * dminfo % my_proc_id
+ numToSend(ownedBlockSorted(2,k)) = numToSend(ownedBlockSorted(2,k)) + 1
+ totalSent = totalSent + 1
+ ! recipientList(1,:) represents the index in the srcList to place this data
+ recipientList(1,ownedListSorted(2,k)) = numToSend(ownedBlockSorted(2,k))
+ ! recipientList(2,:) represnets the index in the buffer to place this data
+ recipientList(2,ownedListSorted(2,k)) = totalSent
else
- ownerListOut(j) = ownerListIn(j)
+ ownerListOut(j) = ownerListIn(j)
end if
- end do
+ else
+ ownerListOut(j) = ownerListIn(j)
+ end if
+ end do
- if (numToSend > 0) then
- allocate(sendListPtr % next)
- sendListPtr => sendListPtr % next
- sendListPtr % procID = currentProc
- sendListPtr % blockID = currentProc ! Currently, we have just one block per task, so blockID = procID
- sendListPtr % nlist = numToSend
- allocate(sendListPtr % list(numToSend))
- nullify(sendListPtr % next)
+ fieldCursor => ownedListField
+ do while (associated(fieldCursor))
+ iBlock = fieldCursor % block % localBlockID + 1
+
+ ! Find end of send list
+ ! *** NEED TO HANDLE COPY LISTS TOO ***
+ exchListPtr => fieldCursor % sendList(haloLayer)
+ exchListPtr2 => fieldCursor % sendList(haloLayer) % next
+ do while(associated(exchListPtr2))
+ exchListPtr => exchListPtr % next
+ exchListPtr2 => exchListPtr2 % next
+ end do
+
+ if (numToSend(iBlock) > 0) then
+ allocate(exchListPtr % next)
+ exchListPtr => exchListPtr % next
+ exchListPtr % endPointID = currentProc
+ exchListPtr % nlist = numToSend(iBlock)
+ allocate(exchListPtr % srcList(numToSend(iBlock)))
+ allocate(exchListPtr % destList(numToSend(iBlock)))
+ nullify(exchListPtr % next)
kk = 1
do j=1,nOwnedList
- if (recipientList(j) /= -1) then
- sendListPtr % list(recipientList(j)) = j
+ if (recipientList(1,j) /= -1) then
+ if(ownedBlock(j) == fieldCursor % block % blockID) then
+ exchListPtr % srcList(recipientList(1,j)) = ownedListIndex(j)
+ exchListPtr % destList(recipientList(1,j)) = recipientList(2,j)
kk = kk + 1
- end if
+ end if
+ end if
end do
- end if
+ end if
- nMesgSend = nMesgRecv
- call MPI_Irecv(nMesgRecv, 1, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
- call MPI_Isend(nMesgSend, 1, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
- call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
- call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
- call MPI_Irecv(ownerListIn, nMesgRecv, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
- call MPI_Isend(ownerListOut, nMesgSend, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
- call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
- call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
+ fieldCursor => fieldCursor % next
+ end do
+
+ nMesgSend = nMesgRecv
+ call MPI_Irecv(nMesgRecv, 1, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(nMesgSend, 1, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Irecv(ownerListIn, nMesgRecv, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(ownerListOut, nMesgSend, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
end do
+
+ !
+ ! With our needed list returned to us, build receive lists based on which indices were
+ ! marked by other tasks
+ !
do i=0, dminfo % nprocs - 1
+ if(i .ne. dminfo % my_proc_id) then
+ numToRecv(:) = 0
+ do j=1,nNeededList
+ if (ownerListIn(j) == -i) numToRecv(neededBlock(j)) = numToRecv(neededBlock(j)) + 1
+ end do
- numToRecv = 0
- do j=1,nNeededList
- if (ownerListIn(j) == -i) numToRecv = numToRecv + 1
- end do
- if (numToRecv > 0) then
- allocate(recvListPtr % next)
- recvListPtr => recvListPtr % next
- recvListPtr % procID = i
- recvListPtr % blockID = i ! Currently, we have just one block per task, so blockID = procID
- recvListPtr % nlist = numToRecv
- allocate(recvListPtr % list(numToRecv))
- nullify(recvListPtr % next)
- kk = 1
- do j=1,nNeededList
- if (ownerListIn(j) == -i) then
- recvListPtr % list(kk) = j + offset
- kk = kk + 1
- end if
+ fieldCursor => neededListField
+ totalRecv = 0
+ do while (associated(fieldCursor))
+ iBlock = fieldCursor % block % localBlockID + 1
+
+ ! Find end of recv list
+ exchListPtr => fieldCursor % recvList(haloLayer)
+ exchListPtr2 => fieldCursor % recvList(haloLayer) % next
+ do while(associated(exchListPtr2))
+ exchListPtr => exchListPtr % next
+ exchListPtr2 => exchListPtr2 % next
end do
- end if
+ if (numToRecv(iBlock) > 0) then
+ allocate(exchListPtr % next)
+ exchListPtr => exchListPtr % next
+ exchListPtr % endPointID = i
+ exchListPtr % nlist = numToRecv(iBlock)
+ allocate(exchListPtr % srcList(numToRecv(iBlock)))
+ allocate(exchListPtr % destList(numToRecv(iBlock)))
+ nullify(exchListPtr % next)
+ kk = 1
+ do j=1,nNeededList
+ if (ownerListIn(j) == -i) then
+ if (neededBlock(j) == fieldCursor % block % blockID) then
+ totalRecv = totalRecv + 1
+ exchListPtr % srcList(kk) = totalRecv
+ exchListPtr % destList(kk) = neededListIndex(j) + offsetList(iBlock)
+ kk = kk + 1
+ end if
+ end if
+ end do
+ end if
+
+ fieldCursor => fieldCursor % next
+ end do
+ end if
end do
+ !
+ ! Free up memory
+ !
+ deallocate(numToSend)
+ deallocate(numToRecv)
+ deallocate(ownedList)
+ deallocate(ownedListIndex)
+ deallocate(ownedBlock)
+ deallocate(neededList)
+ deallocate(neededListIndex)
+ deallocate(neededBlock)
+ deallocate(ownedListSorted)
+ deallocate(ownedBlockSorted)
+ deallocate(recipientList)
deallocate(ownerListIn)
deallocate(ownerListOut)
+ deallocate(offsetList)
+#endif
- sendListPtr => sendList
- sendList => sendList % next
- deallocate(sendListPtr)
+ ! Build Copy Lists
+ allocate(numToSend(1))
+ fieldCursor => ownedListField
+ do while (associated(fieldCursor))
+ allocate(ownedListSorted(2, fieldCursor % dimSizes(1)))
+ allocate(recipientList(2, fieldcursor % dimSizes(1)))
- recvListPtr => recvList
- recvList => recvList % next
- deallocate(recvListPtr)
+ numToSend = 0
+ recipientList = -1
-#else
- allocate(recvList)
- recvList % procID = dminfo % my_proc_id
- recvList % blockID = dminfo % my_proc_id ! Currently, we have just one block per task, so blockID = procID
- recvList % nlist = nNeededList
- allocate(recvList % list(nNeededList))
- nullify(recvList % next)
- do j=1,nNeededList
- recvList % list(j) = j
+ do i = 1, fieldCursor % dimSizes(1)
+ ownedListSorted(1, i) = fieldCursor % array(i)
+ ownedListSorted(2, i) = i
+ end do
+
+ call quicksort(fieldCursor % dimSizes(1), ownedListSorted)
+
+ fieldCursor2 => neededListField
+ do while(associated(fieldCursor2))
+ do i = 1, fieldCursor2 % dimSizes(1)
+ k = mpas_binary_search(ownedListSorted, 2, 1, fieldCursor % dimSizes(1), fieldCursor2 % array(i))
+ if (k <= fieldCursor % dimSizes(1)) then
+ numToSend(1) = numToSend(1) + 1
+ ! recipientList(1,:) represents the needed block id
+ recipientList(1,ownedListSorted(2,k)) = fieldCursor2 % block % localBlockID
+ ! recipientList(2,:) represnets the index in the buffer to place this data
+ recipientList(2,ownedListSorted(2,k)) = i
+ end if
+ end do
+
+ if(numToSend(1) > 0) then
+ ! Find end of copy list
+ exchListPtr => fieldCursor % copyList(haloLayer)
+ exchListPtr2 => fieldCursor % copyList(haloLayer) % next
+ do while(associated(exchListPtr2))
+ exchListPtr => exchListPtr % next
+ exchListPtr2 => exchListPtr2 % next
+ end do
+
+ allocate(exchListPtr % next)
+ exchListPtr => exchListPtr % next
+ exchListPtr % endPointID = fieldCursor2 % block % localBlockID
+ exchListPtr % nlist = numToSend(1)
+ allocate(exchListPtr % srcList(numToSend(1)))
+ allocate(exchListPtr % destList(numToSend(1)))
+ nullify(exchListPtr % next)
+ kk = 1
+ do j=1,fieldCursor % dimSizes(1)
+ if(recipientList(1,j) == fieldCursor2 % block % blockID) then
+ exchListPtr % srcList(kk) = j
+ exchListPtr % destList(kk) = recipientList(2,j)
+ kk = kk + 1
+ end if
+ end do
+ end if
+ fieldCursor2 => fieldCursor % next
+ end do
+
+ deallocate(recipientList)
+ deallocate(ownedListSorted)
+ fieldCursor => fieldCursor % next
end do
+ deallocate(numToSend)
- allocate(sendList)
- sendList % procID = dminfo % my_proc_id
- sendList % blockID = dminfo % my_proc_id ! Currently, we have just one block per task, so blockID = procID
- sendList % nlist = nOwnedList
- allocate(sendList % list(nOwnedList))
- nullify(sendList % next)
- do j=1,nOwnedList
- sendList % list(j) = j
+ !
+ ! The first item in each send and recv list is invalid, so advance these pointers
+ ! to point to the first valid item in the list
+ !
+ fieldCursor => ownedListField
+ do while (associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList(haloLayer)
+ fieldCursor % sendList(haloLayer) = fieldCursor % sendList(haloLayer) % next
+ deallocate(exchListPtr)
+
+ fieldCursor => fieldCursor % next
end do
-#endif
- end subroutine mpas_dmpar_get_owner_list!}}}
+ fieldCursor => neededListField
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList(haloLayer)
+ fieldCursor % recvList(haloLayer) = fieldCursor % recvList(haloLayer) % next
+ deallocate(exchListPtr)
- subroutine mpas_dmpar_alltoall_field1d_integer(dminfo, fieldIn, fieldout)!{{{
+ exchListPtr => fieldCursor % copyList(haloLayer)
+ fieldCursor % copyList(haloLayer) = fieldCursor % copyList(haloLayer) % next
+ deallocate(exchListPtr)
+ fieldcursor => fieldCursor % next
+ end do
+
+ end subroutine mpas_dmpar_get_exch_list!}}}
+
+ subroutine mpas_dmpar_alltoall_field1d_integer(fieldIn, fieldout, haloLayersIn)!{{{
+
implicit none
- type (dm_info), intent(in) :: dminfo
type (field1dInteger), pointer :: fieldIn
type (field1dInteger), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
type (field1dInteger), pointer :: fieldInPtr, fieldOutPtr
- type (exchange_list), pointer :: sendListPtr, recvListPtr, copyListPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
+ logical :: comm_list_found
+
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: i
+ integer :: iHalo, i
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+ dminfo => fieldIn % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
- ! Initiate mpi_irecv calls
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
+ allocate(recvList)
+ nullify(recvList % next)
- do while(associated(recvListPtr))
- allocate(recvListPtr % ibuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ ! Setup recieve lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
- recvListPtr => recvListPtr % next
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr
+ end do
+
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
end do
- fieldOutPtr => fieldOutPtr % next
end do
- ! Initiate mpi_isend calls, and handle local copies
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ commListPtr % ibuffer(exchListPtr % destList(i) + bufferOffset) = fieldInPtr % array(exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
- if (sendListPtr % procID == dminfo % my_proc_id) then ! Local Copy
+ call MPI_Isend(commListPtr % ibuffer, commListPtr % nlist, MPI_INTEGERKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+#endif
+
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- if(fieldOutPtr % block % blockID == sendListPtr % blockID) then
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while(associated(copyListPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(copyListPtr % list(i)) = fieldInPtr % array(sendListPtr % list(i))
- end do
- end if
- copyListPtr => copyListPtr % next
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(exchListPtr % destList(i)) = fieldInPtr % array(exchListPtr % srcList(i))
end do
end if
fieldOutPtr => fieldOutPtr % next
end do
- else ! mpi_isend
- allocate(sendListPtr % ibuffer(sendListPtr % nlist))
- call mpas_pack_send_buf1d_integer(fieldInPtr % dimSizes(1), fieldInPtr % array, sendListPtr, 1, sendListPtr % nlist, &
- sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
+
+ exchListPtr => exchListPtr % next
+ end do
end do
- fieldInPtr => fieldInPtr % next
end do
- ! Recieve all mpi_irecv commands, and unpack data into array
- ! Deallocate recieve buffers
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
- do while (associated(recvListPtr))
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call mpas_unpack_recv_buf1d_integer(fieldOutPtr % dimSizes(1), fieldOutPtr % array, recvListPtr, 1, recvListPtr % nlist, &
- recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- recvListPtr => recvListPtr % next
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(exchListPtr % destList(i)) = commListPtr % ibuffer(exchListPtr % srcList(i) + bufferOffset)
+ nAdded = nAdded + 1
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
end do
- fieldOutPtr => fieldOutPtr % next
+
+ commListPtr => commListPtr % next
end do
- ! Dellocate send buffers
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
- fieldInPtr => fieldInPtr % next
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
end do
-#else
- ! Only local copies if no mpi
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while (associated(copyListPtr))
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if(sendListPtr % blockID == fieldOutPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(copyListPtr % list(i)) = fieldInPtr % array(sendListPtr % list(i))
- end do
- end if
- sendListPtr => sendListPtr % next
- end do
- end if
- fieldInPtr => fieldInPtr % next
- end do
- copyListPtr => copyListPtr % next
- end do
- fieldOutPtr => fieldOutPtr % next
- end do
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
end subroutine mpas_dmpar_alltoall_field1d_integer!}}}
- subroutine mpas_dmpar_alltoall_field2d_integer(dminfo, fieldIn, fieldout)!{{{
+ subroutine mpas_dmpar_alltoall_field2d_integer(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
type (field2dInteger), pointer :: fieldIn
type (field2dInteger), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
type (field2dInteger), pointer :: fieldInPtr, fieldOutPtr
- type (exchange_list), pointer :: sendListPtr, recvListPtr, copyListPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
- integer :: nBuffer
+ logical :: comm_list_found
+
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: i
+ integer :: iHalo, i, j
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(i)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = i
+ end do
+ end if
+
#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
- ! Initiate mpi_irecv calls
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
+ allocate(recvList)
+ nullify(recvList % next)
- do while(associated(recvListPtr))
- nBuffer = recvListPtr % nList * fieldOutPtr % dimSizes(1)
- allocate(recvListPtr % ibuffer(nBuffer))
- call MPI_Irecv(recvListPtr % ibuffer, nBuffer, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
-
- recvListPtr => recvListPtr % next
+ ! Setup recieve lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
end do
- fieldOutPtr => fieldOutPtr % next
end do
- ! Initiate mpi_isend calls, and handle local copies
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr
+ end do
- if (sendListPtr % procID == dminfo % my_proc_id) then ! Local Copy
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- if(fieldOutPtr % block % blockID == sendListPtr % blockID) then
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while(associated(copyListPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(:,copyListPtr % list(i)) = fieldInPtr % array(:,sendListPtr % list(i))
- end do
- end if
- copyListPtr => copyListPtr % next
- end do
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldInPtr % dimSizes(1)
+ comm_list_found = .true.
+ exit
end if
- fieldOutPtr => fieldOutPtr % next
+
+ commListPtr => commListPtr % next
end do
- else ! mpi_isend
- nBuffer = sendLisTPtr % nList * fieldInPtr % dimSizes(1)
- allocate(sendListPtr % ibuffer(nBuffer))
- call mpas_pack_send_buf2d_integer(1, fieldInPtr % dimSizes(1), fieldInPtr % dimSizes(2), fieldInPtr % array, sendListPtr, 1, nBuffer, &
- sendListPtr % ibuffer, nPacked, lastPackedIdx)
-
- call MPI_Isend(sendListPtr % ibuffer, nBuffer, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
end do
- fieldInPtr => fieldInPtr % next
end do
- ! Recieve all mpi_irecv commands, and unpack data into array
- ! Deallocate recieve buffers
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
- do while (associated(recvListPtr))
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(1)
+ commListPtr % ibuffer((exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) + j + bufferOffset) = fieldInPtr % array(j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
- nBuffer = recvListPtr % nList * fieldOutPtr % dimSizes(1)
+ call MPI_Isend(commListPtr % ibuffer, commListPtr % nlist, MPI_INTEGERKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
- call mpas_unpack_recv_buf2d_integer(1, fieldOutPtr % dimSizes(1), fieldOutPtr % dimSizes(2), fieldOutPtr % array, recvListPtr, 1, nBuffer, &
- recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- recvListPtr => recvListPtr % next
- end do
- fieldOutPtr => fieldOutPtr % next
+ commListPtr => commListPtr % next
end do
+#endif
- ! Dellocate send buffers
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(:, exchListPtr % destList(i)) = fieldInPtr % array(:, exchListPtr % srcList(i))
+ end do
+ end if
+ fieldOutPtr => fieldOutPtr % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
end do
- fieldInPtr => fieldInPtr % next
end do
-#else
- ! Only local copies if no mpi
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while (associated(copyListPtr))
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if(sendListPtr % blockID == fieldOutPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(:, copyListPtr % list(i)) = fieldInPtr % array(:, sendListPtr % list(i))
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(1)
+ fieldOutPtr % array(j, exchListPtr % destList(i)) = commListPtr % ibuffer((exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(1) + j + bufferOffset)
+ nAdded = nAdded + 1
end do
- end if
- sendListPtr => sendListPtr % next
- end do
- end if
- fieldInPtr => fieldInPtr % next
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
end do
- copyListPtr => copyListPtr % next
+ bufferOffset = bufferOffset + nAdded
end do
- fieldOutPtr => fieldOutPtr % next
+
+ commListPtr => commListPtr % next
end do
+
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
end subroutine mpas_dmpar_alltoall_field2d_integer!}}}
- subroutine mpas_dmpar_alltoall_field3d_integer(dminfo, fieldIn, fieldout)!{{{
+ subroutine mpas_dmpar_alltoall_field3d_integer(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
type (field3dInteger), pointer :: fieldIn
type (field3dInteger), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
type (field3dInteger), pointer :: fieldInPtr, fieldOutPtr
- type (exchange_list), pointer :: sendListPtr, recvListPtr, copyListPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
- integer :: nBuffer
+ logical :: comm_list_found
+
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: i
+ integer :: iHalo, i, j, k
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(i)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = i
+ end do
+ end if
+
#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
- ! Initiate mpi_irecv calls
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
+ allocate(recvList)
+ nullify(recvList % next)
- do while(associated(recvListPtr))
- nBuffer = recvListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
- allocate(recvListPtr % ibuffer(nBuffer))
- call MPI_Irecv(recvListPtr % ibuffer, nBuffer, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ ! Setup recieve lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
- recvListPtr => recvListPtr % next
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr
+ end do
+
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
end do
- fieldOutPtr => fieldOutPtr % next
end do
- ! Initiate mpi_isend calls, and handle local copies
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
-
- if (sendListPtr % procID == dminfo % my_proc_id) then ! Local Copy
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- if(fieldOutPtr % block % blockID == sendListPtr % blockID) then
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while(associated(copyListPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(:,:,copyListPtr % list(i)) = fieldInPtr % array(:,:,sendListPtr % list(i))
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(1)
+ do k = 1, fieldInPtr % dimSizes(2)
+ commListPtr % ibuffer((exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) + (j-1) * fieldInPtr % dimSizes(1) + k &
+ + bufferOffset) = fieldInPtr % array(k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
end do
- end if
- copyListPtr => copyListPtr % next
+ end do
end do
end if
- fieldOutPtr => fieldOutPtr % next
+
+ exchListPtr => exchListPtr % next
end do
- else ! mpi_isend
- nBuffer = sendLisTPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2)
- allocate(sendListPtr % ibuffer(nBuffer))
- call mpas_pack_send_buf3d_integer(1, fieldInPtr % dimSizes(1), 1, fieldInPtr % dimSizes(2), fieldInPtr % dimSizes(3), &
- fieldInPtr % array, sendListPtr, 1, nBuffer, &
- sendListPtr % ibuffer, nPacked, lastPackedIdx)
-
- call MPI_Isend(sendListPtr % ibuffer, nBuffer, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
end do
- fieldInPtr => fieldInPtr % next
- end do
- ! Recieve all mpi_irecv commands, and unpack data into array
- ! Deallocate recieve buffers
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
- do while (associated(recvListPtr))
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Isend(commListPtr % ibuffer, commListPtr % nlist, MPI_INTEGERKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
- nBuffer = recvListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
-
- call mpas_unpack_recv_buf3d_integer(1, fieldOutPtr % dimSizes(1), 1, fieldOutPtr % dimSizes(2), fieldOutPtr % dimSizes(3), &
- fieldOutPtr % array, recvListPtr, 1, nBuffer, &
- recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- recvListPtr => recvListPtr % next
- end do
- fieldOutPtr => fieldOutPtr % next
+ commListPtr => commListPtr % next
end do
+#endif
- ! Dellocate send buffers
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(:, :, exchListPtr % destList(i)) = fieldInPtr % array(:, :, exchListPtr % srcList(i))
+ end do
+ end if
+ fieldOutPtr => fieldOutPtr % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
end do
- fieldInPtr => fieldInPtr % next
end do
-#else
- ! Only local copies if no mpi
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while (associated(copyListPtr))
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if(sendListPtr % blockID == fieldOutPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(:, :, copyListPtr % list(i)) = fieldInPtr % array(:, :, sendListPtr % list(i))
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(1)
+ do k = 1, fieldOutPtr % dimSizes(2)
+ fieldOutPtr % array(k, j, exchListPtr % destList(i)) = commListPtr % ibuffer((exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) &
+ + (j-1) * fieldOutPtr % dimSizes(1) + k + bufferOffset)
+ nAdded = nAdded + 1
+ end do
end do
- end if
- sendListPtr => sendListPtr % next
- end do
- end if
- fieldInPtr => fieldInPtr % next
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
end do
- copyListPtr => copyListPtr % next
+ bufferOffset = bufferOffset + nAdded
end do
- fieldOutPtr => fieldOutPtr % next
+
+ commListPtr => commListPtr % next
end do
+
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
end subroutine mpas_dmpar_alltoall_field3d_integer!}}}
- subroutine mpas_dmpar_alltoall_field1d_real(dminfo, fieldIn, fieldout)!{{{
+ subroutine mpas_dmpar_alltoall_field1d_real(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
type (field1dReal), pointer :: fieldIn
type (field1dReal), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
type (field1dReal), pointer :: fieldInPtr, fieldOutPtr
- type (exchange_list), pointer :: sendListPtr, recvListPtr, copyListPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
+ logical :: comm_list_found
+
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: i
+ integer :: iHalo, i
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(i)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = i
+ end do
+ end if
+
#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
- ! Initiate mpi_irecv calls
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
+ allocate(recvList)
+ nullify(recvList % next)
- do while(associated(recvListPtr))
- allocate(recvListPtr % rbuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % rbuffer, recvListPtr % nlist, MPI_realKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ ! Setup recieve lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
- recvListPtr => recvListPtr % next
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr
+ end do
+
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
end do
- fieldOutPtr => fieldOutPtr % next
end do
- ! Initiate mpi_isend calls, and handle local copies
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ commListPtr % rbuffer(exchListPtr % destList(i) + bufferOffset) = fieldInPtr % array(exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
- if (sendListPtr % procID == dminfo % my_proc_id) then ! Local Copy
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_REALKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+#endif
+
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- if(fieldOutPtr % block % blockID == sendListPtr % blockID) then
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while(associated(copyListPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(copyListPtr % list(i)) = fieldInPtr % array(sendListPtr % list(i))
- end do
- end if
- copyListPtr => copyListPtr % next
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(exchListPtr % destList(i)) = fieldInPtr % array(exchListPtr % srcList(i))
end do
end if
fieldOutPtr => fieldOutPtr % next
end do
- else ! mpi_isend
- allocate(sendListPtr % rbuffer(sendListPtr % nlist))
- call mpas_pack_send_buf1d_real(fieldInPtr % dimSizes(1), fieldInPtr % array, sendListPtr, 1, sendListPtr % nlist, &
- sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_realKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
+
+ exchListPtr => exchListPtr % next
+ end do
end do
- fieldInPtr => fieldInPtr % next
end do
- ! Recieve all mpi_irecv commands, and unpack data into array
- ! Deallocate recieve buffers
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
- do while (associated(recvListPtr))
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call mpas_unpack_recv_buf1d_real(fieldOutPtr % dimSizes(1), fieldOutPtr % array, recvListPtr, 1, recvListPtr % nlist, &
- recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- recvListPtr => recvListPtr % next
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(exchListPtr % destList(i)) = commListPtr % rbuffer(exchListPtr % srcList(i) + bufferOffset)
+ nAdded = nAdded + 1
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
end do
- fieldOutPtr => fieldOutPtr % next
+
+ commListPtr => commListPtr % next
end do
- ! Dellocate send buffers
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
- fieldInPtr => fieldInPtr % next
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
end do
-#else
- ! Only local copies if no mpi
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while (associated(copyListPtr))
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if(sendListPtr % blockID == fieldOutPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(copyListPtr % list(i)) = fieldInPtr % array(sendListPtr % list(i))
- end do
- end if
- sendListPtr => sendListPtr % next
- end do
- end if
- fieldInPtr => fieldInPtr % next
- end do
- copyListPtr => copyListPtr % next
- end do
- fieldOutPtr => fieldOutPtr % next
- end do
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
end subroutine mpas_dmpar_alltoall_field1d_real!}}}
- subroutine mpas_dmpar_alltoall_field2d_real(dminfo, fieldIn, fieldout)!{{{
+ subroutine mpas_dmpar_alltoall_field2d_real(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
type (field2dReal), pointer :: fieldIn
type (field2dReal), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
type (field2dReal), pointer :: fieldInPtr, fieldOutPtr
- type (exchange_list), pointer :: sendListPtr, recvListPtr, copyListPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
- integer :: nBuffer
+ logical :: comm_list_found
+
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: i
+ integer :: iHalo, i, j
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(i)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = i
+ end do
+ end if
+
#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
- ! Initiate mpi_irecv calls
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
+ allocate(recvList)
+ nullify(recvList % next)
- do while(associated(recvListPtr))
- nBuffer = recvListPtr % nList * fieldOutPtr % dimSizes(1)
- allocate(recvListPtr % rbuffer(nBuffer))
- call MPI_Irecv(recvListPtr % rbuffer, nBuffer, MPI_realKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
-
- recvListPtr => recvListPtr % next
+ ! Setup recieve lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
end do
- fieldOutPtr => fieldOutPtr % next
end do
- ! Initiate mpi_isend calls, and handle local copies
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr
+ end do
- if (sendListPtr % procID == dminfo % my_proc_id) then ! Local Copy
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- if(fieldOutPtr % block % blockID == sendListPtr % blockID) then
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while(associated(copyListPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(:,copyListPtr % list(i)) = fieldInPtr % array(:,sendListPtr % list(i))
- end do
- end if
- copyListPtr => copyListPtr % next
- end do
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldInPtr % dimSizes(1)
+ comm_list_found = .true.
+ exit
end if
- fieldOutPtr => fieldOutPtr % next
+
+ commListPtr => commListPtr % next
end do
- else ! mpi_isend
- nBuffer = sendLisTPtr % nList * fieldInPtr % dimSizes(1)
- allocate(sendListPtr % rbuffer(nBuffer))
- call mpas_pack_send_buf2d_real(1, fieldInPtr % dimSizes(1), fieldInPtr % dimSizes(2), fieldInPtr % array, sendListPtr, 1, nBuffer, &
- sendListPtr % rbuffer, nPacked, lastPackedIdx)
-
- call MPI_Isend(sendListPtr % rbuffer, nBuffer, MPI_realKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
end do
- fieldInPtr => fieldInPtr % next
end do
- ! Recieve all mpi_irecv commands, and unpack data into array
- ! Deallocate recieve buffers
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
- do while (associated(recvListPtr))
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) + j + bufferOffset) = fieldInPtr % array(j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
- nBuffer = recvListPtr % nList * fieldOutPtr % dimSizes(1)
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_REALKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
- call mpas_unpack_recv_buf2d_real(1, fieldOutPtr % dimSizes(1), fieldOutPtr % dimSizes(2), fieldOutPtr % array, recvListPtr, 1, nBuffer, &
- recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- recvListPtr => recvListPtr % next
- end do
- fieldOutPtr => fieldOutPtr % next
+ commListPtr => commListPtr % next
end do
+#endif
- ! Dellocate send buffers
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(:, exchListPtr % destList(i)) = fieldInPtr % array(:, exchListPtr % srcList(i))
+ end do
+ end if
+ fieldOutPtr => fieldOutPtr % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
end do
- fieldInPtr => fieldInPtr % next
end do
-#else
- ! Only local copies if no mpi
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while (associated(copyListPtr))
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if(sendListPtr % blockID == fieldOutPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(:, copyListPtr % list(i)) = fieldInPtr % array(:, sendListPtr % list(i))
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(1)
+ fieldOutPtr % array(j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(1) + j + bufferOffset)
+ nAdded = nAdded + 1
end do
- end if
- sendListPtr => sendListPtr % next
- end do
- end if
- fieldInPtr => fieldInPtr % next
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
end do
- copyListPtr => copyListPtr % next
+ bufferOffset = bufferOffset + nAdded
end do
- fieldOutPtr => fieldOutPtr % next
+
+ commListPtr => commListPtr % next
end do
+
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
end subroutine mpas_dmpar_alltoall_field2d_real!}}}
- subroutine mpas_dmpar_alltoall_field3d_real(dminfo, fieldIn, fieldout)!{{{
+ subroutine mpas_dmpar_alltoall_field3d_real(fieldIn, fieldout, haloLayersIn)!{{{
implicit none
- type (dm_info), intent(in) :: dminfo
type (field3dReal), pointer :: fieldIn
type (field3dReal), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
type (field3dReal), pointer :: fieldInPtr, fieldOutPtr
- type (exchange_list), pointer :: sendListPtr, recvListPtr, copyListPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
- integer :: nBuffer
+ logical :: comm_list_found
+
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: i
+ integer :: iHalo, i, j, k
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(i)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = i
+ end do
+ end if
+
#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
- ! Initiate mpi_irecv calls
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
+ allocate(recvList)
+ nullify(recvList % next)
- do while(associated(recvListPtr))
- nBuffer = recvListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
- allocate(recvListPtr % rbuffer(nBuffer))
- call MPI_Irecv(recvListPtr % rbuffer, nBuffer, MPI_realKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ ! Setup recieve lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
- recvListPtr => recvListPtr % next
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr
+ end do
+
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
end do
- fieldOutPtr => fieldOutPtr % next
end do
- ! Initiate mpi_isend calls, and handle local copies
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
-
- if (sendListPtr % procID == dminfo % my_proc_id) then ! Local Copy
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- if(fieldOutPtr % block % blockID == sendListPtr % blockID) then
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while(associated(copyListPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(:,:,copyListPtr % list(i)) = fieldInPtr % array(:,:,sendListPtr % list(i))
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(1)
+ do k = 1, fieldInPtr % dimSizes(2)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) + (j-1) * fieldInPtr % dimSizes(1) + k &
+ + bufferOffset) = fieldInPtr % array(k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
end do
- end if
- copyListPtr => copyListPtr % next
+ end do
end do
end if
- fieldOutPtr => fieldOutPtr % next
+
+ exchListPtr => exchListPtr % next
end do
- else ! mpi_isend
- nBuffer = sendLisTPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2)
- allocate(sendListPtr % rbuffer(nBuffer))
- call mpas_pack_send_buf3d_real(1, fieldInPtr % dimSizes(1), 1, fieldInPtr % dimSizes(2), fieldInPtr % dimSizes(3), &
- fieldInPtr % array, sendListPtr, 1, nBuffer, &
- sendListPtr % rbuffer, nPacked, lastPackedIdx)
-
- call MPI_Isend(sendListPtr % rbuffer, nBuffer, MPI_realKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
end do
- fieldInPtr => fieldInPtr % next
- end do
- ! Recieve all mpi_irecv commands, and unpack data into array
- ! Deallocate recieve buffers
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- recvListPtr => fieldOutPtr % recvList(1) % next
- do while (associated(recvListPtr))
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_REALKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
- nBuffer = recvListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
-
- call mpas_unpack_recv_buf3d_real(1, fieldOutPtr % dimSizes(1), 1, fieldOutPtr % dimSizes(2), fieldOutPtr % dimSizes(3), &
- fieldOutPtr % array, recvListPtr, 1, nBuffer, &
- recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- recvListPtr => recvListPtr % next
- end do
- fieldOutPtr => fieldOutPtr % next
+ commListPtr => commListPtr % next
end do
+#endif
- ! Dellocate send buffers
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(:, :, exchListPtr % destList(i)) = fieldInPtr % array(:, :, exchListPtr % srcList(i))
+ end do
+ end if
+ fieldOutPtr => fieldOutPtr % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
end do
- fieldInPtr => fieldInPtr % next
end do
-#else
- ! Only local copies if no mpi
- fieldOutPtr => fieldOut
- do while (associated(fieldOutPtr))
- copyListPtr => fieldOutPtr % copyList(1) % next
- do while (associated(copyListPtr))
- fieldInPtr => fieldIn
- do while (associated(fieldInPtr))
- if(copyListPtr % blockID == fieldInPtr % block % blockID) then
- sendListPtr => fieldInPtr % sendList(1) % next
- do while (associated(sendListPtr))
- if(sendListPtr % blockID == fieldOutPtr % block % blockID) then
- do i = 1, copyListPtr % nList
- fieldOutPtr % array(:, :, copyListPtr % list(i)) = fieldInPtr % array(:, :, sendListPtr % list(i))
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(1)
+ do k = 1, fieldOutPtr % dimSizes(2)
+ fieldOutPtr % array(k, j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) &
+ + (j-1) * fieldOutPtr % dimSizes(1) + k + bufferOffset)
+ nAdded = nAdded + 1
+ end do
end do
- end if
- sendListPtr => sendListPtr % next
- end do
- end if
- fieldInPtr => fieldInPtr % next
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
end do
- copyListPtr => copyListPtr % next
+ bufferOffset = bufferOffset + nAdded
end do
- fieldOutPtr => fieldOutPtr % next
+
+ commListPtr => commListPtr % next
end do
+
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
end subroutine mpas_dmpar_alltoall_field3d_real!}}}
- subroutine mpas_pack_send_buf1d_integer(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)!{{{
+ subroutine mpas_dmpar_exch_halo_field1d_integer(field, haloLayersIn)!{{{
implicit none
- integer, intent(in) :: nField, nBuffer, startPackIdx
- integer, dimension(*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- integer, dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
+ type (field1DInteger), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
- integer :: i
+ type (dm_info), pointer :: dminfo
+ type (field1DInteger), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ integer :: mpi_ierr
+ integer :: nHaloLayers, iHalo, i
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + 1
- if (nPacked > nBuffer) then
- nPacked = nPacked - 1
- lastPackedIdx = i - 1
- return
- end if
- buffer(nPacked) = field(sendList % list(i))
- end do
- lastPackedIdx = sendList % nlist
+ logical comm_list_found
- end subroutine mpas_pack_send_buf1d_integer!}}}
+ dminfo => field % block % domain % dminfo
- subroutine mpas_pack_send_buf2d_integer(ds, de, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)!{{{
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
- implicit none
+#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
- integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
- integer, dimension(ds:de,*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- integer, dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
- integer :: i, n
+ dminfo = field % block % domain % dminfo
- n = de-ds+1
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
- if (n > nBuffer) then
- write(0,*) 'packSendBuf2dInteger: Not enough space in buffer', &
- ' to fit a single slice.'
- return
- end if
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + n
- if (nPacked > nBuffer) then
- nPacked = nPacked - n
- lastPackedIdx = i - 1
- return
- end if
- buffer(nPacked-n+1:nPacked) = field(ds:de,sendList % list(i))
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ ! Determine size from recv lists
+ exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
end do
- lastPackedIdx = sendList % nlist
- end subroutine mpas_pack_send_buf2d_integer!}}}
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
- subroutine mpas_pack_send_buf3d_integer(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)!{{{
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
- implicit none
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
- integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
- integer, dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- integer, dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
+ commListPtr => commListPtr % next
+ end do
- integer :: i, j, k, n
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ commListPtr % ibuffer(exchListPtr % destList(i) + bufferOffset) = fieldCursor % array(exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end if
- n = (d1e-d1s+1) * (d2e-d2s+1)
+ exchListPtr => exchListPtr % next
+ end do
- if (n > nBuffer) then
- write(0,*) 'packSendBuf3dInteger: Not enough space in buffer', &
- ' to fit a single slice.'
- return
- end if
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + n
- if (nPacked > nBuffer) then
- nPacked = nPacked - n
- lastPackedIdx = i - 1
- return
- end if
- k = nPacked-n+1
- do j=d2s,d2e
- buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
- k = k + d1e-d1s+1
- end do
+ call MPI_Isend(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
end do
- lastPackedIdx = sendList % nlist
+#endif
- end subroutine mpas_pack_send_buf3d_integer!}}}
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(field))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
- subroutine mpas_pack_send_buf1d_real(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)!{{{
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(exchListPtr % destList(i)) = fieldCursor % array(exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
- implicit none
+ exchListPtr => exchListPtr % next
+ end do
+ end do
- integer, intent(in) :: nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
+ fieldCursor => fieldCursor % next
+ end do
- integer :: i
+#ifdef _MPI
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + 1
- if (nPacked > nBuffer) then
- nPacked = nPacked - 1
- lastPackedIdx = i - 1
- return
- end if
- buffer(nPacked) = field(sendList % list(i))
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList(iHalo)
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor % array(exchListPtr % destList(i)) = commListPtr % ibuffer(exchListPtr % srcList(i) + bufferOffset)
+ nAdded = nAdded + 1
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
end do
- lastPackedIdx = sendList % nlist
- end subroutine mpas_pack_send_buf1d_real!}}}
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
- subroutine mpas_pack_send_buf2d_real(ds, de, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)!{{{
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+ end subroutine mpas_dmpar_exch_halo_field1d_integer!}}}
+
+ subroutine mpas_dmpar_exch_halo_field2d_integer(field, haloLayersIn)!{{{
+
implicit none
- integer, intent(in) :: ds, de, nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(ds:de,*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
+ type (field2DInteger), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
- integer :: i, n
+ type (dm_info), pointer :: dminfo
+ type (field2DInteger), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ integer :: mpi_ierr
+ integer :: nHaloLayers, iHalo, i, j
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
- n = de-ds+1
+ logical comm_list_found
- if (n > nBuffer) then
- write(0,*) 'packSendBuf2dReal: Not enough space in buffer', &
- ' to fit a single slice.'
- return
+ dminfo => field % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
end if
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + n
- if (nPacked > nBuffer) then
- nPacked = nPacked - n
- lastPackedIdx = i - 1
- return
- end if
- buffer(nPacked-n+1:nPacked) = field(ds:de,sendList % list(i))
- end do
- lastPackedIdx = sendList % nlist
+#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
- end subroutine mpas_pack_send_buf2d_real!}}}
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
- subroutine mpas_pack_send_buf3d_real(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)!{{{
+ dminfo = field % block % domain % dminfo
- implicit none
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
- integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
- real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
- type (exchange_list), intent(in) :: sendList
- real (kind=RKIND), dimension(nBuffer), intent(out) :: buffer
- integer, intent(inout) :: nPacked, lastPackedIdx
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- integer :: i, j, k, n
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1)
+ exit
+ end if
- n = (d1e-d1s+1) * (d2e-d2s+1)
+ commListPtr => commListPtr % next
+ end do
- if (n > nBuffer) then
- write(0,*) 'packSendBuf3dReal: Not enough space in buffer', &
- ' to fit a single slice.'
- return
- end if
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- nPacked = 0
- do i=startPackIdx, sendList % nlist
- nPacked = nPacked + n
- if (nPacked > nBuffer) then
- nPacked = nPacked - n
- lastPackedIdx = i - 1
- return
- end if
- k = nPacked-n+1
- do j=d2s,d2e
- buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
- k = k + d1e-d1s+1
- end do
- end do
- lastPackedIdx = sendList % nlist
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1)
+ end if
- end subroutine mpas_pack_send_buf3d_real!}}}
+ exchListPtr => exchListPtr % next
+ end do
- subroutine mpas_unpack_recv_buf1d_integer(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)!{{{
+ ! Determine size from recv lists
+ exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- implicit none
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1)
+ exit
+ end if
- integer, intent(in) :: nField, nBuffer, startUnpackIdx
- integer, dimension(*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- integer, dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+ commListPtr => commListPtr % next
+ end do
- integer :: i
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + 1
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - 1
- lastUnpackedIdx = i - 1
- return
- end if
- field(recvList % list(i)) = buffer(nUnpacked)
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
end do
- lastUnpackedIdx = recvList % nlist
- end subroutine mpas_unpack_recv_buf1d_integer!}}}
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
- subroutine mpas_unpack_recv_buf2d_integer(ds, de, nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)!{{{
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
- implicit none
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
- integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
- integer, dimension(ds:de,*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- integer, dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+ commListPtr => commListPtr % next
+ end do
- integer :: i, n
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(1)
+ commListPtr % ibuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) + j + bufferOffset) = fieldCursor % array(j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end if
- n = de-ds+1
+ exchListPtr => exchListPtr % next
+ end do
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + n
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - n
- lastUnpackedIdx = i - 1
- return
- end if
- field(ds:de,recvList % list(i)) = buffer(nUnpacked-n+1:nUnpacked)
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
end do
- lastUnpackedIdx = recvList % nlist
+#endif
- end subroutine mpas_unpack_recv_buf2d_integer!}}}
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(field))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
- subroutine mpas_unpack_recv_buf3d_integer(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &!{{{
- nUnpacked, lastUnpackedIdx)
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(:, exchListPtr % destList(i)) = fieldCursor % array(:, exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
- implicit none
+ exchListPtr => exchListPtr % next
+ end do
+ end do
- integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
- integer, dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- integer, dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+ fieldCursor => fieldCursor % next
+ end do
- integer :: i, j, k, n
+#ifdef _MPI
- n = (d1e-d1s+1) * (d2e-d2s+1)
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList(iHalo)
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(j, exchListPtr % destList(i)) = commListPtr % ibuffer((exchListPtr % srcList(i)-1)*fieldCursor % dimSizeS(1) + j + bufferOffset)
+ nAdded = nAdded + 1
+ end do
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
+ end do
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + n
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - n
- lastUnpackedIdx = i - 1
- return
- end if
- k = nUnpacked-n+1
- do j=d2s,d2e
- field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
- k = k + d1e-d1s+1
- end do
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
end do
- lastUnpackedIdx = recvList % nlist
- end subroutine mpas_unpack_recv_buf3d_integer!}}}
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
- subroutine mpas_dmpar_exch_halo_field1d_integer(field, haloLayers)!{{{
+ end subroutine mpas_dmpar_exch_halo_field2d_integer!}}}
+ subroutine mpas_dmpar_exch_halo_field3d_integer(field, haloLayersIn)!{{{
+
implicit none
- type (field1DInteger), intent(inout) :: field
- integer, dimension(:), intent(in), optional :: haloLayers
+ type (field3DInteger), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
- type (dm_info) :: dminfo
- type (exchange_list), pointer :: sendList, recvList
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ type (dm_info), pointer :: dminfo
+ type (field3DInteger), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
integer :: mpi_ierr
- integer, dimension(size(field % dimSizes)) :: dims
+ integer :: nHaloLayers, iHalo, i, j, k
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
+ logical comm_list_found
+
+ dminfo => field % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
+
dminfo = field % block % domain % dminfo
- dims = field % dimSizes
- call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- allocate(recvListPtr % ibuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- allocate(sendListPtr % ibuffer(sendListPtr % nlist))
- call mpas_pack_send_buf1d_integer(dims(1), field % array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call mpas_unpack_recv_buf1d_integer(dims(1), field % array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2)
+ exit
+ end if
- call mpas_destroy_exchange_list(sendList)
- call mpas_destroy_exchange_list(recvList)
+ commListPtr => commListPtr % next
+ end do
-#endif
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- end subroutine mpas_dmpar_exch_halo_field1d_integer!}}}
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2)
+ end if
- subroutine mpas_dmpar_exch_halo_field2d_integer(field, haloLayers)!{{{
+ exchListPtr => exchListPtr % next
+ end do
- implicit none
+ ! Determine size from recv lists
+ exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- type (field2DInteger), intent(inout) :: field
- integer, dimension(:), intent(in), optional :: haloLayers
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2)
+ exit
+ end if
- type (dm_info) :: dminfo
- type (exchange_list), pointer :: sendList, recvList
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: d2
- integer, dimension(size(field % dimSizes)) :: dims
+ commListPtr => commListPtr % next
+ end do
-#ifdef _MPI
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- dminfo = field % block % domain % dminfo
- dims = field % dimSizes
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2)
+ end if
- call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+ exchListPtr => exchListPtr % next
+ end do
+ end do
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d2 = dims(1) * recvListPtr % nlist
- allocate(recvListPtr % ibuffer(d2))
- call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
+ fieldCursor => fieldCursor % next
end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d2 = dims(1) * sendListPtr % nlist
- allocate(sendListPtr % ibuffer(d2))
- call mpas_pack_send_buf2d_integer(1, dims(1), dims(2), field % array, sendListPtr, 1, d2, sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d2 = dims(1) * recvListPtr % nlist
- call mpas_unpack_recv_buf2d_integer(1, dims(1), dims(2), field % array, recvListPtr, 1, d2, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
- call mpas_destroy_exchange_list(sendList)
- call mpas_destroy_exchange_list(recvList)
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
-#endif
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
- end subroutine mpas_dmpar_exch_halo_field2d_integer!}}}
+ commListPtr => commListPtr % next
+ end do
- subroutine mpas_dmpar_exch_halo_field3d_integer(field, haloLayers)!{{{
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % ibuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(2)
+ do k = 1, fieldCursor % dimSizes(1)
+ commListPtr % ibuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (j-1) * fieldCursor % dimSizes(1) + k + bufferOffset) = fieldCursor % array(k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end if
- implicit none
+ exchListPtr => exchListPtr % next
+ end do
- type (field3DInteger), intent(inout) :: field
- integer, dimension(:), intent(in), optional :: haloLayers
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
- type (dm_info) :: dminfo
- type (exchange_list), pointer :: sendList, recvList
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: d3
- integer, dimension(size(field % dimSizes)) :: dims
+ call MPI_Isend(commListPtr % ibuffer, commListPtr % nList, MPI_INTEGERKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+#endif
-#ifdef _MPI
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(field))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
- dminfo = field % block % domain % dminfo
- dims = field % dimSizes
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(:, :, exchListPtr % destList(i)) = fieldCursor % array(:, :, exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
- call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+ exchListPtr => exchListPtr % next
+ end do
+ end do
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d3 = dims(1) * dims(2) * recvListPtr % nlist
- allocate(recvListPtr % ibuffer(d3))
- call MPI_Irecv(recvListPtr % ibuffer, d3, MPI_INTEGERKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
+ fieldCursor => fieldCursor % next
end do
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d3 = dims(1) * dims(2) * sendListPtr % nlist
- allocate(sendListPtr % ibuffer(d3))
- call mpas_pack_send_buf3d_integer(1, dims(1), 1, dims(2), dims(3), field % array, sendListPtr, 1, d3, &
- sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, d3, MPI_INTEGERKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
+#ifdef _MPI
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d3 = dims(1) * dims(2) * recvListPtr % nlist
- call mpas_unpack_recv_buf3d_integer(1, dims(1), 1, dims(2), dims(3), field % array, recvListPtr, 1, d3, &
- recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % ibuffer)
- end if
- recvListPtr => recvListPtr % next
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList(iHalo)
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(2)
+ do k = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(k, j, exchListPtr % destList(i)) = commListPtr % ibuffer((exchListPtr % srcList(i)-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (j-1)*fieldCursor % dimSizes(1) + k + bufferOffset)
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
end do
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % ibuffer)
- end if
- sendListPtr => sendListPtr % next
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
end do
- call mpas_destroy_exchange_list(sendList)
- call mpas_destroy_exchange_list(recvList)
-
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
end subroutine mpas_dmpar_exch_halo_field3d_integer!}}}
-
- subroutine mpas_unpack_recv_buf1d_real(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)!{{{
+ subroutine mpas_dmpar_exch_halo_field1d_real(field, haloLayersIn)!{{{
+
implicit none
- integer, intent(in) :: nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+ type (field1dReal), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
- integer :: i
+ type (dm_info), pointer :: dminfo
+ type (field1dReal), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ integer :: mpi_ierr
+ integer :: nHaloLayers, iHalo, i
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + 1
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - 1
- lastUnpackedIdx = i - 1
- return
- end if
- field(recvList % list(i)) = buffer(nUnpacked)
- end do
- lastUnpackedIdx = recvList % nlist
+ logical comm_list_found
- end subroutine mpas_unpack_recv_buf1d_real!}}}
+ dminfo => field % block % domain % dminfo
- subroutine mpas_unpack_recv_buf2d_real(ds, de, nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)!{{{
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
- implicit none
+#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
- integer, intent(in) :: ds, de, nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(ds:de,*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
- integer :: i, n
+ dminfo = field % block % domain % dminfo
- n = de-ds+1
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + n
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - n
- lastUnpackedIdx = i - 1
- return
- end if
- field(ds:de,recvList % list(i)) = buffer(nUnpacked-n+1:nUnpacked)
- end do
- lastUnpackedIdx = recvList % nlist
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- end subroutine mpas_unpack_recv_buf2d_real!}}}
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList
+ exit
+ end if
- subroutine mpas_unpack_recv_buf3d_real(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &!{{{
- nUnpacked, lastUnpackedIdx)
+ commListPtr => commListPtr % next
+ end do
- implicit none
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
- real (kind=RKIND), dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
- type (exchange_list), intent(in) :: recvList
- real (kind=RKIND), dimension(nBuffer), intent(in) :: buffer
- integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList
+ end if
- integer :: i, j, k, n
+ exchListPtr => exchListPtr % next
+ end do
- n = (d1e-d1s+1) * (d2e-d2s+1)
+ ! Determine size from recv lists
+ exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- nUnpacked = 0
- do i=startUnpackIdx, recvList % nlist
- nUnpacked = nUnpacked + n
- if (nUnpacked > nBuffer) then
- nUnpacked = nUnpacked - n
- lastUnpackedIdx = i - 1
- return
- end if
- k = nUnpacked-n+1
- do j=d2s,d2e
- field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
- k = k + d1e-d1s+1
- end do
- end do
- lastUnpackedIdx = recvList % nlist
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList
+ exit
+ end if
- end subroutine mpas_unpack_recv_buf3d_real!}}}
+ commListPtr => commListPtr % next
+ end do
- subroutine mpas_dmpar_exch_halo_field1d_real(field, haloLayers)!{{{
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- implicit none
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList
+ end if
- type (field1DReal), intent(inout) :: field
- integer, dimension(:), intent(in), optional :: haloLayers
+ exchListPtr => exchListPtr % next
+ end do
+ end do
- type (dm_info) :: dminfo
- type (exchange_list), pointer :: sendList, recvList
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer, dimension(size(field % dimSizes)) :: dims
+ fieldCursor => fieldCursor % next
+ end do
-#ifdef _MPI
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
- dminfo = field % block % domain % dminfo
- dims = field % dimSizes
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
- call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- allocate(recvListPtr % rbuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % rbuffer, recvListPtr % nlist, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
+ commListPtr => commListPtr % next
end do
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- allocate(sendListPtr % rbuffer(sendListPtr % nlist))
- call mpas_pack_send_buf1d_real(dims(1), field % array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ commListPtr % rbuffer(exchListPtr % destList(i) + bufferOffset) = fieldCursor % array(exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
end do
+#endif
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call mpas_unpack_recv_buf1d_real(dims(1), field % array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(field))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
+
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(exchListPtr % destList(i)) = fieldCursor % array(exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
end do
-
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
+
+#ifdef _MPI
+
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList(iHalo)
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor % array(exchListPtr % destList(i)) = commListPtr % rbuffer(exchListPtr % srcList(i) + bufferOffset)
+ nAdded = nAdded + 1
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
end do
- call mpas_destroy_exchange_list(sendList)
- call mpas_destroy_exchange_list(recvList)
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
end subroutine mpas_dmpar_exch_halo_field1d_real!}}}
- subroutine mpas_dmpar_exch_halo_field2d_real(field, haloLayers)!{{{
+ subroutine mpas_dmpar_exch_halo_field2d_real(field, haloLayersIn)!{{{
implicit none
- type (field2DReal), intent(inout) :: field
- integer, dimension(:), intent(in), optional :: haloLayers
+ type (field2dReal), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
- type (dm_info) :: dminfo
- type (exchange_list), pointer :: sendList, recvList
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ type (dm_info), pointer :: dminfo
+ type (field2dReal), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
integer :: mpi_ierr
- integer :: d2
- integer, dimension(size(field % dimSizes)) :: dims
+ integer :: nHaloLayers, iHalo, i, j
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
+ logical comm_list_found
+ dminfo => field % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
+
dminfo = field % block % domain % dminfo
- dims = field % dimSizes
- call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d2 = dims(1) * recvListPtr % nlist
- allocate(recvListPtr % rbuffer(d2))
- call MPI_Irecv(recvListPtr % rbuffer, d2, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
- end do
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d2 = dims(1) * sendListPtr % nlist
- allocate(sendListPtr % rbuffer(d2))
- call mpas_pack_send_buf2d_real(1, dims(1), dims(2), field % array, sendListPtr, 1, d2, sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, d2, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
- end do
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1)
+ exit
+ end if
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d2 = dims(1) * recvListPtr % nlist
- call mpas_unpack_recv_buf2d_real(1, dims(1), dims(2), field % array, recvListPtr, 1, d2, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
- end do
+ commListPtr => commListPtr % next
+ end do
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
- end do
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- call mpas_destroy_exchange_list(sendList)
- call mpas_destroy_exchange_list(recvList)
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1)
+ end if
-#endif
+ exchListPtr => exchListPtr % next
+ end do
- end subroutine mpas_dmpar_exch_halo_field2d_real!}}}
+ ! Determine size from recv lists
+ exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- subroutine mpas_dmpar_exch_halo_field3d_real(field, haloLayers)!{{{
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1)
+ exit
+ end if
- implicit none
+ commListPtr => commListPtr % next
+ end do
- type (field3DReal), intent(inout) :: field
- integer, dimension(:), intent(in), optional :: haloLayers
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- type (dm_info) :: dminfo
- type (exchange_list), pointer :: sendList, recvList
- type (exchange_list), pointer :: sendListPtr, recvListPtr
- integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
- integer :: mpi_ierr
- integer :: d3
- integer, dimension(size(field % dimSizes)) :: dims
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1)
+ end if
-#ifdef _MPI
+ exchListPtr => exchListPtr % next
+ end do
+ end do
- dminfo = field % block % domain % dminfo
- dims = field % dimSizes
+ fieldCursor => fieldCursor % next
+ end do
- call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- d3 = dims(1) * dims(2) * recvListPtr % nlist
- allocate(recvListPtr % rbuffer(d3))
- call MPI_Irecv(recvListPtr % rbuffer, d3, MPI_REALKIND, &
- recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
- end if
- recvListPtr => recvListPtr % next
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
+
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
end do
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- d3 = dims(1) * dims(2) * sendListPtr % nlist
- allocate(sendListPtr % rbuffer(d3))
- call mpas_pack_send_buf3d_real(1, dims(1), 1, dims(2), dims(3), field % array, sendListPtr, 1, d3, &
- sendListPtr % rbuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % rbuffer, d3, MPI_REALKIND, &
- sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
- end if
- sendListPtr => sendListPtr % next
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) + j + bufferOffset) = fieldCursor % array(j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
end do
+#endif
- recvListPtr => recvList
- do while (associated(recvListPtr))
- if (recvListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d3 = dims(1) * dims(2) * recvListPtr % nlist
- call mpas_unpack_recv_buf3d_real(1, dims(1), 1, dims(2), dims(3), field % array, recvListPtr, 1, d3, &
- recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
- deallocate(recvListPtr % rbuffer)
- end if
- recvListPtr => recvListPtr % next
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(field))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
+
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(:, exchListPtr % destList(i)) = fieldCursor % array(:, exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
end do
- sendListPtr => sendList
- do while (associated(sendListPtr))
- if (sendListPtr % procID /= dminfo % my_proc_id) then
- call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- deallocate(sendListPtr % rbuffer)
- end if
- sendListPtr => sendListPtr % next
+#ifdef _MPI
+
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList(iHalo)
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1)*fieldCursor % dimSizeS(1) + j + bufferOffset)
+ nAdded = nAdded + 1
+ end do
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
end do
- call mpas_destroy_exchange_list(sendList)
- call mpas_destroy_exchange_list(recvList)
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
#endif
- end subroutine mpas_dmpar_exch_halo_field3d_real!}}}
+ end subroutine mpas_dmpar_exch_halo_field2d_real!}}}
- subroutine mpas_aggregate_exchange_lists(myProcID, haloLayersIn, sendListArray, recvListArray, aggregateSendList, aggregateRecvList)!{{{
+ subroutine mpas_dmpar_exch_halo_field3d_real(field, haloLayersIn)!{{{
implicit none
- !--- in variables ---!
- integer, intent(in) :: myProcID
- integer, dimension(:), intent(in), target, optional :: haloLayersIn
- type (exchange_list), dimension(:), pointer :: sendListArray, recvListArray
-
- !--- out variabls ---!
- type (exchange_list), pointer :: aggregateSendList, aggregateRecvList
+ type (field3dReal), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
- !--- local variables ---!
- integer :: i, j
+ type (dm_info), pointer :: dminfo
+ type (field3dReal), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ integer :: mpi_ierr
+ integer :: nHaloLayers, iHalo, i, j, k
+ integer :: bufferOffset, nAdded
integer, dimension(:), pointer :: haloLayers
- type (exchange_list), pointer :: inListPtr, aggListPtr
- logical :: blockAdded
- logical :: listInitilized
- if (present(haloLayersIn)) then
- haloLayers => haloLayersIn
+ logical comm_list_found
+
+ dminfo => field % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
else
- allocate(haloLayers(size(sendListArray)))
- do i=1, size(haloLayers)
- haloLayers(i) = i
- end do
+ nHaloLayers = size(field % sendList)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
end if
- nullify(aggregateSendList)
- nullify(aggregateRecvList)
+#ifdef _MPI
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
- do i=1, size(haloLayers)
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
- inListPtr => sendListArray(haloLayers(i)) % next
- do while(associated(inListPtr))
+ dminfo = field % block % domain % dminfo
- blockAdded = .false.
- aggListPtr => aggregateSendList
-
- do while(associated(aggListPtr))
- if(inListPtr % blockID == aggListPtr % blockID) then
- if(inListPtr % procID .ne. myProcID) then
- call mpas_merge_integer_arrays(aggListPtr % list, aggListPtr % nlist, inListPtr % list)
- end if
- blockAdded = .true.
- exit
- end if
- aggListPtr => aggListPtr % next
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
+
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2)
+ exit
+ end if
+
+ commListPtr => commListPtr % next
end do
- if(.not. blockAdded) then
-
- if (.not. associated(aggregateSendList)) then
- allocate(aggregateSendList)
- nullify(aggregateSendList % next)
- aggListPtr => aggregateSendList
- else
- aggListPtr => aggregateSendList
- do while(associated(aggListPtr % next))
- aggListPtr => aggListPtr % next
- end do
- allocate(aggListPtr % next)
- aggListPtr => aggListPtr % next
- end if
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- nullify(aggListPtr % next)
- aggListPtr % procID = inListPtr % procID
- aggListPtr % blockID = inListPtr % blockID
- aggListPtr % nlist = inListPtr % nlist
- allocate(aggListPtr % list(inListPtr % nlist))
- aggListPtr % list = inListPtr % list
- aggListPtr % reqID = inListPtr % reqID
-
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2)
end if
- inListPtr => inListPtr % next
- end do
+ exchListPtr => exchListPtr % next
+ end do
+ ! Determine size from recv lists
+ exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
- inListPtr => recvListArray(haloLayers(i)) % next
- do while(associated(inListPtr))
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2)
+ exit
+ end if
- blockAdded = .false.
- aggListPtr => aggregateRecvList
- do while(associated(aggListPtr))
- if(inListPtr % blockID == aggListPtr % blockID) then
- if(inListPtr % procID .ne. myProcID) then
- call mpas_merge_integer_arrays(aggListPtr % list, aggListPtr % nlist, inListPtr % list)
- end if
- blockAdded = .true.
- exit
- end if
- aggListPtr => aggListPtr % next
+ commListPtr => commListPtr % next
end do
- if(.not. blockAdded) then
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
- if (.not. associated(aggregateRecvList)) then
- allocate(aggregateRecvList)
- nullify(aggregateRecvList % next)
- aggListPtr => aggregateRecvList
- else
- aggListPtr => aggregateRecvList
- do while(associated(aggListPtr % next))
- aggListPtr => aggListPtr % next
- end do
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2)
+ end if
- allocate(aggListPtr % next)
- aggListPtr => aggListPtr % next
- nullify(aggListPtr % next)
- end if
-
- aggListPtr % procID = inListPtr % procID
- aggListPtr % blockID = inListPtr % blockID
- aggListPtr % nlist = inListPtr % nlist
- allocate(aggListPtr % list(inListPtr % nlist))
- aggListPtr % list = inListPtr % list
- aggListPtr % reqID = inListPtr % reqID
+ exchListPtr => exchListPtr % next
+ end do
+ end do
- end if
+ fieldCursor => fieldCursor % next
+ end do
- inListPtr => inListPtr % next
- end do
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
+
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
end do
- if (.not. present(haloLayersIn)) then
- deallocate(haloLayers)
- end if
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(2)
+ do k = 1, fieldCursor % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (j-1) * fieldCursor % dimSizes(1) + k + bufferOffset) = fieldCursor % array(k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end if
- end subroutine mpas_aggregate_exchange_lists!}}}
+ exchListPtr => exchListPtr % next
+ end do
- subroutine mpas_destroy_exchange_list(exchangeList)!{{{
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
- implicit none
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+#endif
- !--- in variables ---!
- type (exchange_list), pointer :: exchangeList
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(field))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
- !--- local variables ---!
- type (exchange_list), pointer :: exchangeListPtr
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(:, :, exchListPtr % destList(i)) = fieldCursor % array(:, :, exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
- do while (associated(exchangeList))
- exchangeListPtr => exchangeList % next
+ exchListPtr => exchListPtr % next
+ end do
+ end do
- deallocate(exchangeList % list)
- deallocate(exchangeList)
- exchangeList => exchangeListPtr
+ fieldCursor => fieldCursor % next
end do
- end subroutine mpas_destroy_exchange_list!}}}
+#ifdef _MPI
- subroutine mpas_merge_integer_arrays(mergeArray, nMergeArray, dataToAppend)!{{{
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList(iHalo)
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(2)
+ do k = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(k, j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (j-1)*fieldCursor % dimSizes(1) + k + bufferOffset)
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
+ end do
- implicit none
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
- !--- inout variables ---!
- integer, dimension(:), pointer :: mergeArray
- integer, intent(inout) :: nMergeArray
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
- !--- in variables ---!
- integer, dimension(:), pointer :: dataToAppend
+ end subroutine mpas_dmpar_exch_halo_field3d_real!}}}
- !--- local variables ---!
- integer :: nDataToAppend, newSize
- integer, dimension(nMergeArray) :: mergeArrayCopy
-
-
- nDataToAppend = size(dataToAppend)
- newSize = nMergeArray + nDataToAppend
- mergeArrayCopy = mergeArray
- deallocate(mergeArray)
- allocate(mergeArray(newSize))
- mergeArray(1:nMergeArray) = mergeArrayCopy
- mergeArray(nMergeArray+1:newSize) = dataToAppend
- nMergeArray = newSize
+ subroutine mpas_dmpar_destroy_communication_list(commList)!{{{
+ type (mpas_communication_list), pointer :: commList
+ type (mpas_communication_list), pointer :: commListPtr
- end subroutine mpas_merge_integer_arrays!}}}
+ commListPtr => commList
+ do while(associated(commList))
+ if(associated(commList)) then
+ commList => commList % next
+ else
+ nullify(commList)
+ end if
+ if(allocated(commListPtr % ibuffer)) then
+ deallocate(commListPtr % ibuffer)
+ end if
+
+ if(allocated(commListPtr % rbuffer)) then
+ deallocate(commListPtr % rbuffer)
+ end if
+ deallocate(commListPtr)
+ commListPtr => recvList
+ end do
+ end subroutine mpas_dmpar_destroy_communication_list!}}}
+
+ subroutine mpas_dmpar_destroy_exchange_list(exchList)!{{{
+ type (mpas_exchange_list), pointer :: exchList
+ type (mpas_exchange_list), pointer :: exchListPtr
+
+ exchListPtr => exchList
+ do while(associated(exchList))
+ if(associated(exchList % next)) then
+ exchList => exchList % next
+ else
+ nullify(exchList)
+ end if
+
+ if(allocated(exchListPtr % srcList)) then
+ deallocate(exchListPtr % srcList)
+ end if
+
+ if(allocated(exchListPtr % destList)) then
+ deallocate(exchListPtr % destList)
+ end if
+
+ deallocate(exchListPtr)
+ exchListPtr => exchList
+ end do
+
+ end subroutine mpas_dmpar_destroy_exchange_list!}}}
+
end module mpas_dmpar
</font>
</pre>