<p><b>dwj07@fsu.edu</b> 2013-02-06 15:13:05 -0700 (Wed, 06 Feb 2013)</p><p><br>
-- BRANCH COMMIT --<br>
<br>
Adding the capability to have 4d and 5d reals from registry. Or super arrays of 4d reals.<br>
<br>
This does not create 4d and 5d integers, or super arrays of 5d reals.<br>
</p><hr noshade><pre><font color="gray">Modified: branches/mpas_cdg_advection/src/framework/mpas_dmpar.F
===================================================================
--- branches/mpas_cdg_advection/src/framework/mpas_dmpar.F 2013-02-06 20:22:23 UTC (rev 2448)
+++ branches/mpas_cdg_advection/src/framework/mpas_dmpar.F 2013-02-06 22:13:05 UTC (rev 2449)
@@ -25,6 +25,8 @@
module procedure mpas_dmpar_alltoall_field1d_real
module procedure mpas_dmpar_alltoall_field2d_real
module procedure mpas_dmpar_alltoall_field3d_real
+ module procedure mpas_dmpar_alltoall_field4d_real
+ module procedure mpas_dmpar_alltoall_field5d_real
end interface
private :: mpas_dmpar_alltoall_field1d_integer
@@ -32,6 +34,8 @@
private :: mpas_dmpar_alltoall_field1d_real
private :: mpas_dmpar_alltoall_field2d_real
private :: mpas_dmpar_alltoall_field3d_real
+ private :: mpas_dmpar_alltoall_field4d_real
+ private :: mpas_dmpar_alltoall_field5d_real
interface mpas_dmpar_exch_halo_field
@@ -41,6 +45,8 @@
module procedure mpas_dmpar_exch_halo_field1d_real
module procedure mpas_dmpar_exch_halo_field2d_real
module procedure mpas_dmpar_exch_halo_field3d_real
+ module procedure mpas_dmpar_exch_halo_field4d_real
+ module procedure mpas_dmpar_exch_halo_field5d_real
end interface
private :: mpas_dmpar_exch_halo_field1d_integer
@@ -49,6 +55,8 @@
private :: mpas_dmpar_exch_halo_field1d_real
private :: mpas_dmpar_exch_halo_field2d_real
private :: mpas_dmpar_exch_halo_field3d_real
+ private :: mpas_dmpar_exch_halo_field4d_real
+ private :: mpas_dmpar_exch_halo_field5d_real
interface mpas_dmpar_copy_field
module procedure mpas_dmpar_copy_field1d_integer
@@ -57,6 +65,8 @@
module procedure mpas_dmpar_copy_field1d_real
module procedure mpas_dmpar_copy_field2d_real
module procedure mpas_dmpar_copy_field3d_real
+ module procedure mpas_dmpar_copy_field4d_real
+ module procedure mpas_dmpar_copy_field5d_real
end interface
private :: mpas_dmpar_copy_field1d_integer
@@ -65,6 +75,8 @@
private :: mpas_dmpar_copy_field1d_real
private :: mpas_dmpar_copy_field2d_real
private :: mpas_dmpar_copy_field3d_real
+ private :: mpas_dmpar_copy_field4d_real
+ private :: mpas_dmpar_copy_field5d_real
contains
@@ -2810,7 +2822,610 @@
end subroutine mpas_dmpar_alltoall_field3d_real!}}}
+ subroutine mpas_dmpar_alltoall_field4d_real(fieldIn, fieldout, haloLayersIn)!{{{
+ implicit none
+
+ type (field4dReal), pointer :: fieldIn
+ type (field4dReal), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
+
+ type (field4dReal), pointer :: fieldInPtr, fieldOutPtr
+ 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 :: iHalo, iBuffer, i, j, k, l
+ 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 % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ nullify(sendList)
+ nullify(recvList)
+
+ ! Setup recieve lists.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ 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) * fieldOutPtr % dimSizes(3)
+ 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
+ if(.not.associated(recvList)) then
+ allocate(recvList)
+ nullify(recvList % next)
+ commListPtr => recvList
+ else
+ 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)
+ end if
+
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
+
+ ! Determine size of receive list buffers.
+ 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 % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = nAdded
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_realKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % 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 % halos(haloLayers(iHalo)) % exchList
+ 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) * fieldOutPtr % dimSizes(3)
+ 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
+ if(.not.associated(sendList)) then
+ allocate(sendList)
+ nullify(sendList % next)
+ commListPtr => sendList
+ else
+ 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)
+ end if
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(3)
+ do k = 1, fieldInPtr % dimSizes(2)
+ do l = 1, fieldInPtr % dimSizes(1)
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) &
+ + (j-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) &
+ + (k-1) * fieldInPtr % dimSizes(1) + l + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % 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
+
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
+ 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
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+#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 % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(3)
+ do k = 1, fieldOutPtr % dimSizes(2)
+ do l = 1, fieldOutPtr % dimSizes(1)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(1) &
+ + (j-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) &
+ + (k-1) * fieldOutPtr % dimSizes(1) + l + bufferOffset
+ fieldOutPtr % array(l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ 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
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_alltoall_field4d_real!}}}
+
+ subroutine mpas_dmpar_alltoall_field5d_real(fieldIn, fieldout, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field5dReal), pointer :: fieldIn
+ type (field5dReal), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
+
+ type (field5dReal), pointer :: fieldInPtr, fieldOutPtr
+ 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 :: iHalo, iBuffer, i, j, k, l, m
+ 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 % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ nullify(sendList)
+ nullify(recvList)
+
+ ! Setup recieve lists.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ 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) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4)
+ 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
+ if(.not.associated(recvList)) then
+ allocate(recvList)
+ nullify(recvList % next)
+ commListPtr => recvList
+ else
+ 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)
+ end if
+
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
+
+ ! Determine size of receive list buffers.
+ 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 % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = nAdded
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_realKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % 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 % halos(haloLayers(iHalo)) % exchList
+ 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) * fieldOutPtr % dimSizes(3) * fieldInPtr % dimSizes(4)
+ 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
+ if(.not.associated(sendList)) then
+ allocate(sendList)
+ nullify(sendList % next)
+ commListPtr => sendList
+ else
+ 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)
+ end if
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldInPtr % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(4)
+ do k = 1, fieldInPtr % dimSizes(3)
+ do l = 1, fieldInPtr % dimSizes(2)
+ do m = 1, fieldInPtr % dimSizes(1)
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) * fieldInPtr % dimSizes(4) &
+ + (j-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) &
+ + (k-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) &
+ + (l-1) * fieldInPtr % dimSizes(1) + m + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(m, l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % 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
+
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
+ 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
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+#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 % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(4)
+ do k = 1, fieldOutPtr % dimSizes(3)
+ do l = 1, fieldOutPtr % dimSizes(2)
+ do m = 1, fieldOutPtr % dimSizes(1)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(4) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(1) &
+ + (j-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) &
+ + (k-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) &
+ + (l-1) * fieldOutPtr % dimSizes(1) + m + bufferOffset
+ fieldOutPtr % array(m, l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
+ end do
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ 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
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_alltoall_field5d_real!}}}
+
+
+
subroutine mpas_dmpar_exch_halo_field1d_integer(field, haloLayersIn)!{{{
implicit none
@@ -4507,6 +5122,602 @@
end subroutine mpas_dmpar_exch_halo_field3d_real!}}}
+ subroutine mpas_dmpar_exch_halo_field4d_real(field, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field4dReal), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
+
+ type (dm_info), pointer :: dminfo
+ type (field4dReal), 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, l
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
+
+ logical :: comm_list_found
+
+ do i = 1, 4
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
+ 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 % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ ! Allocate communication lists, and setup dead header nodes
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
+ sendList % nList = 0
+
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
+ recvList % nList = 0
+
+ dminfo = field % block % domain % dminfo
+
+ ! 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 % halos(haloLayers(iHalo)) % exchList
+ 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) * fieldCursor % dimSizes(3)
+ 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 * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ ! Setup recv lists
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ 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
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % 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)
+
+ ! Determine size of recv lists
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = bufferOffset
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! 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))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(3)
+ do k = 1, fieldCursor % dimSizes(2)
+ do l = 1, fieldCursor % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (j-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (k-1) * fieldCursor % dimSizes(1) + l + bufferOffset) &
+ = fieldCursor % array(l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ 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
+
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
+
+ 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
+
+#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 % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(3)
+ do k = 1, fieldCursor % dimSizes(2)
+ do l = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1)&
+ *fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) *fieldCursor % dimSizes(3)&
+ + (j-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (k-1)*fieldCursor % dimSizes(1) + l + bufferOffset)
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
+ 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
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_exch_halo_field4d_real!}}}
+
+ subroutine mpas_dmpar_exch_halo_field5d_real(field, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field5dReal), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
+
+ type (dm_info), pointer :: dminfo
+ type (field5dReal), 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, l, m
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
+
+ logical :: comm_list_found
+
+ do i = 1, 5
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
+ 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 % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ ! Allocate communication lists, and setup dead header nodes
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
+ sendList % nList = 0
+
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
+ recvList % nList = 0
+
+ dminfo = field % block % domain % dminfo
+
+ ! 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 % halos(haloLayers(iHalo)) % exchList
+ 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) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)
+ 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 * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ ! Setup recv lists
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ 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
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % 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)
+
+ ! Determine size of recv lists
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = bufferOffset
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! 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))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(4)
+ do k = 1, fieldCursor % dimSizes(3)
+ do l = 1, fieldCursor % dimSizes(2)
+ do m = 1, fieldCursor % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4) &
+ + (j-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (k-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (l-1) * fieldCursor % dimSizes(1) + m + bufferOffset) &
+ = fieldCursor % array(m, l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ 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
+
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
+
+ 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
+
+#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 % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(4)
+ do k = 1, fieldCursor % dimSizes(3)
+ do l = 1, fieldCursor % dimSizes(2)
+ do m = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(m, l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1)&
+ *fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) *fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)&
+ + (j-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (k-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (l-1)*fieldCursor % dimSizes(1) + m + bufferOffset)
+ end do
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
+ 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
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_exch_halo_field5d_real!}}}
+
subroutine mpas_dmpar_init_mulithalo_exchange_list(exchList, nHalos)!{{{
type (mpas_multihalo_exchange_list), pointer :: exchList
integer, intent(in) :: nHalos
@@ -4668,4 +5879,30 @@
end if
end subroutine mpas_dmpar_copy_field3d_real!}}}
+ subroutine mpas_dmpar_copy_field4d_real(field)!{{{
+ type (field4dReal), pointer :: field
+ type (field4dReal), pointer :: fieldCursor
+
+ if(associated(field % next)) then
+ fieldCursor => field % next
+ do while(associated(fieldCursor))
+ fieldCursor % array = field % array
+ fieldCursor => fieldCursor % next
+ end do
+ end if
+ end subroutine mpas_dmpar_copy_field4d_real!}}}
+
+ subroutine mpas_dmpar_copy_field5d_real(field)!{{{
+ type (field5dReal), pointer :: field
+ type (field5dReal), pointer :: fieldCursor
+
+ if(associated(field % next)) then
+ fieldCursor => field % next
+ do while(associated(fieldCursor))
+ fieldCursor % array = field % array
+ fieldCursor => fieldCursor % next
+ end do
+ end if
+ end subroutine mpas_dmpar_copy_field5d_real!}}}
+
end module mpas_dmpar
Modified: branches/mpas_cdg_advection/src/framework/mpas_grid_types.F
===================================================================
--- branches/mpas_cdg_advection/src/framework/mpas_grid_types.F 2013-02-06 20:22:23 UTC (rev 2448)
+++ branches/mpas_cdg_advection/src/framework/mpas_grid_types.F 2013-02-06 22:13:05 UTC (rev 2449)
@@ -20,8 +20,66 @@
logical :: output
end type io_info
+ ! Derived type for storing fields
+ type field5DReal
+
+ ! Back-pointer to the containing block
+ type (block_type), pointer :: block
+ ! Raw array holding field data on this block
+ real (kind=RKIND), dimension(:,:,:,:,:), pointer :: array
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=StrKIND) :: fieldName
+ character (len=StrKIND), dimension(:), pointer :: constituentNames => null()
+ character (len=StrKIND), dimension(5) :: dimNames
+ integer, dimension(5) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (field5DReal), pointer :: prev, next
+
+ ! Halo communication lists
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
+ end type field5DReal
+
+
! Derived type for storing fields
+ type field4DReal
+
+ ! Back-pointer to the containing block
+ type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
+ real (kind=RKIND), dimension(:,:,:,:), pointer :: array
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=StrKIND) :: fieldName
+ character (len=StrKIND), dimension(:), pointer :: constituentNames => null()
+ character (len=StrKIND), dimension(4) :: dimNames
+ integer, dimension(4) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (field4DReal), pointer :: prev, next
+
+ ! Halo communication lists
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
+ end type field4DReal
+
+
+
+ ! Derived type for storing fields
type field3DReal
! Back-pointer to the containing block
@@ -370,6 +428,8 @@
module procedure mpas_allocate_scratch_field1d_real
module procedure mpas_allocate_scratch_field2d_real
module procedure mpas_allocate_scratch_field3d_real
+ module procedure mpas_allocate_scratch_field4d_real
+ module procedure mpas_allocate_scratch_field5d_real
module procedure mpas_allocate_scratch_field1d_char
end interface
@@ -380,6 +440,8 @@
module procedure mpas_deallocate_scratch_field1d_real
module procedure mpas_deallocate_scratch_field2d_real
module procedure mpas_deallocate_scratch_field3d_real
+ module procedure mpas_deallocate_scratch_field4d_real
+ module procedure mpas_deallocate_scratch_field5d_real
module procedure mpas_deallocate_scratch_field1d_char
end interface
@@ -392,6 +454,8 @@
module procedure mpas_deallocate_field1d_real
module procedure mpas_deallocate_field2d_real
module procedure mpas_deallocate_field3d_real
+ module procedure mpas_deallocate_field4d_real
+ module procedure mpas_deallocate_field5d_real
module procedure mpas_deallocate_field0d_char
module procedure mpas_deallocate_field1d_char
end interface
@@ -632,6 +696,62 @@
end subroutine mpas_allocate_scratch_field3d_real!}}}
+ subroutine mpas_allocate_scratch_field4d_real(f, single_block_in)!{{{
+ type (field4dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field4dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2), f_cursor % dimSizes(3), f_cursor % dimSizes(4)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2), f % dimSizes(3), f % dimSizes(4)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field4d_real!}}}
+
+ subroutine mpas_allocate_scratch_field5d_real(f, single_block_in)!{{{
+ type (field5dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field5dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2), f_cursor % dimSizes(3), f_cursor % dimSizes(4), f_cursor % dimSizes(5)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2), f % dimSizes(3), f % dimSizes(4), f % dimSizes(5)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field5d_real!}}}
+
subroutine mpas_allocate_scratch_field1d_char(f, single_block_in)!{{{
type (field1dChar), pointer :: f
logical, intent(in), optional :: single_block_in
@@ -834,6 +954,64 @@
end subroutine mpas_deallocate_scratch_field3d_real!}}}
+ subroutine mpas_deallocate_scratch_field4d_real(f, single_block_in)!{{{
+ type (field4dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field4dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field4d_real!}}}
+
+ subroutine mpas_deallocate_scratch_field5d_real(f, single_block_in)!{{{
+ type (field5dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field5dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field5d_real!}}}
+
subroutine mpas_deallocate_scratch_field1d_char(f, single_block_in)!{{{
type (field1dChar), pointer :: f
logical, intent(in), optional :: single_block_in
@@ -1073,6 +1251,60 @@
end subroutine mpas_deallocate_field3d_real!}}}
+ subroutine mpas_deallocate_field4d_real(f)!{{{
+ type (field4dReal), pointer :: f
+ type (field4dReal), pointer :: f_cursor
+
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f % next)) then
+ f => f % next
+ else
+ nullify(f)
+ end if
+
+ if(associated(f_cursor % ioinfo)) then
+ deallocate(f_cursor % ioinfo)
+ end if
+
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ deallocate(f_cursor)
+
+ f_cursor => f
+ end do
+
+ end subroutine mpas_deallocate_field4d_real!}}}
+
+ subroutine mpas_deallocate_field5d_real(f)!{{{
+ type (field5dReal), pointer :: f
+ type (field5dReal), pointer :: f_cursor
+
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f % next)) then
+ f => f % next
+ else
+ nullify(f)
+ end if
+
+ if(associated(f_cursor % ioinfo)) then
+ deallocate(f_cursor % ioinfo)
+ end if
+
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ deallocate(f_cursor)
+
+ f_cursor => f
+ end do
+
+ end subroutine mpas_deallocate_field5d_real!}}}
+
subroutine mpas_deallocate_field0d_char(f)!{{{
type (field0dChar), pointer :: f
type (field0dChar), pointer :: f_cursor
Modified: branches/mpas_cdg_advection/src/framework/mpas_io.F
===================================================================
--- branches/mpas_cdg_advection/src/framework/mpas_io.F 2013-02-06 20:22:23 UTC (rev 2448)
+++ branches/mpas_cdg_advection/src/framework/mpas_io.F 2013-02-06 22:13:05 UTC (rev 2449)
@@ -77,6 +77,7 @@
module procedure MPAS_io_get_var_real2d
module procedure MPAS_io_get_var_real3d
module procedure MPAS_io_get_var_real4d
+ module procedure MPAS_io_get_var_real5d
module procedure MPAS_io_get_var_char0d
end interface MPAS_io_get_var
@@ -91,6 +92,7 @@
module procedure MPAS_io_put_var_real2d
module procedure MPAS_io_put_var_real3d
module procedure MPAS_io_put_var_real4d
+ module procedure MPAS_io_put_var_real5d
module procedure MPAS_io_put_var_char0d
end interface MPAS_io_put_var
@@ -1146,7 +1148,7 @@
subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, &
- realVal, realArray1d, realArray2d, realArray3d, realArray4d, &
+ realVal, realArray1d, realArray2d, realArray3d, realArray4d, realArray5d, &
charVal, ierr)
implicit none
@@ -1163,6 +1165,7 @@
real (kind=RKIND), dimension(:,:), intent(out), optional :: realArray2d
real (kind=RKIND), dimension(:,:,:), intent(out), optional :: realArray3d
real (kind=RKIND), dimension(:,:,:,:), intent(out), optional :: realArray4d
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(out), optional :: realArray5d
character (len=*), intent(out), optional :: charVal
integer, intent(out), optional :: ierr
@@ -1263,6 +1266,10 @@
! write (0,*) ' value is real4'
call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
realArray4d, pio_ierr)
+ else if (present(realArray5d)) then
+! write (0,*) ' value is real5'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray5d, pio_ierr)
else if (present(intArray1d)) then
! write (0,*) ' value is int1'
call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
@@ -1492,6 +1499,26 @@
end subroutine MPAS_io_get_var_real4d
+ subroutine MPAS_io_get_var_real5d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_real5d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, realArray5d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_real5d
+
+
subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr)
implicit none
@@ -1513,7 +1540,7 @@
subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, &
- realVal, realArray1d, realArray2d, realArray3d, realArray4d, &
+ realVal, realArray1d, realArray2d, realArray3d, realArray4d, realArray5d, &
charVal, ierr)
implicit none
@@ -1530,6 +1557,7 @@
real (kind=RKIND), dimension(:,:), intent(in), optional :: realArray2d
real (kind=RKIND), dimension(:,:,:), intent(in), optional :: realArray3d
real (kind=RKIND), dimension(:,:,:,:), intent(in), optional :: realArray4d
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(in), optional :: realArray5d
character (len=*), intent(in), optional :: charVal
integer, intent(out), optional :: ierr
@@ -1629,6 +1657,9 @@
else if (present(realArray4d)) then
call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
realArray4d, pio_ierr)
+ else if (present(realArray5d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray5d, pio_ierr)
else if (present(intArray1d)) then
call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
intArray1d, pio_ierr)
@@ -1852,6 +1883,26 @@
end subroutine MPAS_io_put_var_real4d
+ subroutine MPAS_io_put_var_real5d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_real5d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, realArray5d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_real5d
+
+
subroutine MPAS_io_put_var_char0d(handle, fieldname, val, ierr)
implicit none
Modified: branches/mpas_cdg_advection/src/framework/mpas_io_streams.F
===================================================================
--- branches/mpas_cdg_advection/src/framework/mpas_io_streams.F 2013-02-06 20:22:23 UTC (rev 2448)
+++ branches/mpas_cdg_advection/src/framework/mpas_io_streams.F 2013-02-06 22:13:05 UTC (rev 2449)
@@ -19,6 +19,8 @@
type (field1dReal), pointer :: real1dField => null()
type (field2dReal), pointer :: real2dField => null()
type (field3dReal), pointer :: real3dField => null()
+ type (field4dReal), pointer :: real4dField => null()
+ type (field5dReal), pointer :: real5dField => null()
type (field0dChar), pointer :: char0dField => null()
type (field1dChar), pointer :: char1dField => null()
type (field_list_type), pointer :: next => null()
@@ -44,6 +46,8 @@
module procedure MPAS_streamAddField_1dReal
module procedure MPAS_streamAddField_2dReal
module procedure MPAS_streamAddField_3dReal
+ module procedure MPAS_streamAddField_4dReal
+ module procedure MPAS_streamAddField_5dReal
module procedure MPAS_streamAddField_0dChar
end interface MPAS_streamAddField
@@ -82,8 +86,10 @@
FIELD_1D_REAL = 6, &
FIELD_2D_REAL = 7, &
FIELD_3D_REAL = 8, &
- FIELD_0D_CHAR = 9, &
- FIELD_1D_CHAR = 10
+ FIELD_4D_REAL = 9, &
+ FIELD_5D_REAL = 10, &
+ FIELD_0D_CHAR = 11, &
+ FIELD_1D_CHAR = 12
private mergeArrays
@@ -996,6 +1002,208 @@
end subroutine MPAS_streamAddField_3dReal
+ subroutine MPAS_streamAddField_4dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field4DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field4dReal), pointer :: field_ptr
+ character (len=StrKIND), dimension(5) :: dimNames
+ character (len=StrKIND), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+!write(0,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^ we are adding a super-array'
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_4D_REAL
+ new_field_list_node % real4dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+!write(0,*) 'DEBUGGING : Finished adding 4d real field '//trim(field % fieldName)
+
+ end subroutine MPAS_streamAddField_4dReal
+
+
+ subroutine MPAS_streamAddField_5dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field5DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field5dReal), pointer :: field_ptr
+ character (len=StrKIND), dimension(5) :: dimNames
+ character (len=StrKIND), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+!write(0,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^ we are adding a super-array'
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_5D_REAL
+ new_field_list_node % real5dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+!write(0,*) 'DEBUGGING : Finished adding 3d real field '//trim(field % fieldName)
+
+ end subroutine MPAS_streamAddField_5dReal
+
+
subroutine MPAS_streamAddField_0dChar(stream, field, ierr)
implicit none
@@ -1313,6 +1521,8 @@
type (field1dReal), pointer :: field_1dreal_ptr
type (field2dReal), pointer :: field_2dreal_ptr
type (field3dReal), pointer :: field_3dreal_ptr
+ type (field4dReal), pointer :: field_4dreal_ptr
+ type (field5dReal), pointer :: field_5dreal_ptr
type (field0dChar), pointer :: field_0dchar_ptr
type (field1dChar), pointer :: field_1dchar_ptr
type (field_list_type), pointer :: field_cursor
@@ -1324,6 +1534,8 @@
real (kind=RKIND), dimension(:), pointer :: real1d_temp
real (kind=RKIND), dimension(:,:), pointer :: real2d_temp
real (kind=RKIND), dimension(:,:,:), pointer :: real3d_temp
+ real (kind=RKIND), dimension(:,:,:,:), pointer :: real4d_temp
+ real (kind=RKIND), dimension(:,:,:,:,:), pointer :: real5d_temp
if (present(ierr)) ierr = MPAS_STREAM_NOERR
@@ -1876,7 +2088,185 @@
else
deallocate(real3d_temp)
end if
+ else if (field_cursor % field_type == FIELD_4D_REAL) then
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real3dField % fieldName)
+!write(0,*) 'DEBUGGING : reading a 4d real array'
+ if (field_cursor % real4dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : reading a 4d real super-array'
+ ncons = size(field_cursor % real4dField % constituentNames)
+ allocate(real3d_temp(field_cursor % real4dField % dimSizes(2), &
+ field_cursor % real4dField % dimSizes(3), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real4d_temp(field_cursor % real4dField % dimSizes(1), &
+ field_cursor % real4dField % dimSizes(2), &
+ field_cursor % real4dField % dimSizes(3), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real4dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+!write(0,*) 'DEBUGGING : calling get_var for a constitutent'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real4dField % constituentNames(j), real3d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real4dField % fieldName, real4d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % real4dField % isSuperArray) then
+ deallocate(real3d_temp)
+ else
+ deallocate(real4d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_4dreal_ptr => field_cursor % real4dField
+ i = 1
+ do while (associated(field_4dreal_ptr))
+ if (trim(field_4dreal_ptr % dimNames(4)) == 'nCells') then
+ ownedSize = field_4dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_4dreal_ptr % dimNames(4)) == 'nEdges') then
+ ownedSize = field_4dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_4dreal_ptr % dimNames(4)) == 'nVertices') then
+ ownedSize = field_4dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_4dreal_ptr % dimSizes(4)
+ end if
+
+ if (field_cursor % real4dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : copying the temporary array'
+ field_4dreal_ptr % array(j, :,:,1:ownedSize) = real3d_temp(:,:,i:i+ownedSize-1)
+ else
+ field_4dreal_ptr % array(:,:,:,1:ownedSize) = real4d_temp(:,:,:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real3dField % isSuperArray) then
+ call mpas_dmpar_bcast_reals(field_cursor % real4dField % block % domain % dminfo, size(real3d_temp), real3d_temp(:,1,1))
+ field_4dreal_ptr => field_cursor % real4dField
+ do while (associated(field_4dreal_ptr))
+ field_4dreal_ptr % array(j,:,:,:) = real3d_temp(:,:,:)
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real4dField % block % domain % dminfo, size(real4d_temp), real4d_temp(:,1,1,1))
+ field_4dreal_ptr => field_cursor % real4dField
+ do while (associated(field_4dreal_ptr))
+ field_4dreal_ptr % array(:,:,:,:) = real4d_temp(:,:,:,:)
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % real4dField % isSuperArray) then
+ deallocate(real3d_temp)
+ else
+ deallocate(real4d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_5D_REAL) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real3dField % fieldName)
+!write(0,*) 'DEBUGGING : reading a 4d real array'
+ if (field_cursor % real5dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : reading a 4d real super-array'
+ ncons = size(field_cursor % real5dField % constituentNames)
+ allocate(real4d_temp(field_cursor % real5dField % dimSizes(2), &
+ field_cursor % real5dField % dimSizes(3), &
+ field_cursor % real5dField % dimSizes(4), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real5d_temp(field_cursor % real5dField % dimSizes(1), &
+ field_cursor % real5dField % dimSizes(2), &
+ field_cursor % real5dField % dimSizes(3), &
+ field_cursor % real5dField % dimSizes(4), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real5dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+!write(0,*) 'DEBUGGING : calling get_var for a constitutent'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real5dField % constituentNames(j), real4d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real5dField % fieldName, real5d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % real5dField % isSuperArray) then
+ deallocate(real4d_temp)
+ else
+ deallocate(real5d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_5dreal_ptr => field_cursor % real5dField
+ i = 1
+ do while (associated(field_5dreal_ptr))
+ if (trim(field_5dreal_ptr % dimNames(5)) == 'nCells') then
+ ownedSize = field_5dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_5dreal_ptr % dimNames(5)) == 'nEdges') then
+ ownedSize = field_5dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_5dreal_ptr % dimNames(5)) == 'nVertices') then
+ ownedSize = field_5dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_5dreal_ptr % dimSizes(5)
+ end if
+
+ if (field_cursor % real5dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : copying the temporary array'
+ field_5dreal_ptr % array(j,:,:,:,1:ownedSize) = real4d_temp(:,:,:,i:i+ownedSize-1)
+ else
+ field_5dreal_ptr % array(:,:,:,:,1:ownedSize) = real5d_temp(:,:,:,:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real5dField % isSuperArray) then
+ call mpas_dmpar_bcast_reals(field_cursor % real5dField % block % domain % dminfo, size(real4d_temp), real4d_temp(:,1,1,1))
+ field_5dreal_ptr => field_cursor % real5dField
+ do while (associated(field_5dreal_ptr))
+ field_5dreal_ptr % array(j,:,:,:,:) = real4d_temp(:,:,:,:)
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real5dField % block % domain % dminfo, size(real5d_temp), real5d_temp(:,1,1,1,1))
+ field_5dreal_ptr => field_cursor % real5dField
+ do while (associated(field_5dreal_ptr))
+ field_5dreal_ptr % array(:,:,:,:,:) = real5d_temp(:,:,:,:,:)
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % real5dField % isSuperArray) then
+ deallocate(real4d_temp)
+ else
+ deallocate(real5d_temp)
+ end if
+
+
else if (field_cursor % field_type == FIELD_0D_CHAR) then
!write(0,*) 'Reading in field '//trim(field_cursor % char0dField % fieldName)
</font>
</pre>