<p><b>dwj07@fsu.edu</b> 2012-05-22 14:50:11 -0600 (Tue, 22 May 2012)</p><p><br>
-- BRANCH COMMIT --<br>
<br>
Checkpointing work so far.<br>
<br>
Currently all to all routines work, and exchange list creation appears to work for 0 halo cell fields.<br>
<br>
Added a namelist variable, config_num_halos to specify the number of halo levels wanted.<br>
</p><hr noshade><pre><font color="gray">Modified: branches/omp_blocks/multiple_blocks/Makefile
===================================================================
--- branches/omp_blocks/multiple_blocks/Makefile 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/Makefile 2012-05-22 20:50:11 UTC (rev 1930)
@@ -124,7 +124,7 @@
"FFLAGS_OPT = -O3 -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian -ffree-form" \
"CFLAGS_OPT = -O3 -m64" \
"LDFLAGS_OPT = -O3 -m64" \
- "FFLAGS_DEBUG = -g -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian -ffree-form -fbounds-check" \
+ "FFLAGS_DEBUG = -g -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian -ffree-form -fbounds-check -fbacktrace" \
"CFLAGS_DEBUG = -g -m64" \
"LDFLAGS_DEBUG = -g -m64" \
"CORE = $(CORE)" \
Modified: branches/omp_blocks/multiple_blocks/src/core_hyd_atmos/Registry
===================================================================
--- branches/omp_blocks/multiple_blocks/src/core_hyd_atmos/Registry 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/core_hyd_atmos/Registry 2012-05-22 20:50:11 UTC (rev 1930)
@@ -21,6 +21,7 @@
namelist logical sw_model config_monotonic true
namelist integer sw_model config_mp_physics 0
namelist real sw_model config_apvm_upwinding 0.5
+namelist integer sw_model config_num_halos 2
namelist integer dimensions config_nvertlevels 26
namelist character io config_input_name grid.nc
namelist character io config_output_name output.nc
Modified: branches/omp_blocks/multiple_blocks/src/core_init_nhyd_atmos/Registry
===================================================================
--- branches/omp_blocks/multiple_blocks/src/core_init_nhyd_atmos/Registry 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/core_init_nhyd_atmos/Registry 2012-05-22 20:50:11 UTC (rev 1930)
@@ -7,6 +7,7 @@
namelist character nhyd_model config_stop_time none
namelist integer nhyd_model config_theta_adv_order 3
namelist real nhyd_model config_coef_3rd_order 0.25
+namelist integer nhyd_model config_num_halos 2
namelist integer dimensions config_nvertlevels 26
namelist integer dimensions config_nsoillevels 4
namelist integer dimensions config_nfglevels 27
Modified: branches/omp_blocks/multiple_blocks/src/core_nhyd_atmos/Registry
===================================================================
--- branches/omp_blocks/multiple_blocks/src/core_nhyd_atmos/Registry 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/core_nhyd_atmos/Registry 2012-05-22 20:50:11 UTC (rev 1930)
@@ -35,6 +35,7 @@
namelist logical nhyd_model config_newpx false
namelist real nhyd_model config_apvm_upwinding 0.5
namelist logical nhyd_model config_h_ScaleWithMesh false
+namelist integer nhyd_model config_num_halos 2
namelist real damping config_zd 22000.0
namelist real damping config_xnutr 0.0
namelist integer dimensions config_nvertlevels 26
Modified: branches/omp_blocks/multiple_blocks/src/core_ocean/Registry
===================================================================
--- branches/omp_blocks/multiple_blocks/src/core_ocean/Registry 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/core_ocean/Registry 2012-05-22 20:50:11 UTC (rev 1930)
@@ -13,6 +13,7 @@
namelist logical sw_model config_initial_stats false
namelist logical sw_model config_prescribe_velocity false
namelist logical sw_model config_prescribe_thickness false
+namelist integer sw_model config_num_halos 2
namelist character io config_input_name grid.nc
namelist character io config_output_name output.nc
namelist character io config_restart_name restart.nc
Modified: branches/omp_blocks/multiple_blocks/src/core_sw/Registry
===================================================================
--- branches/omp_blocks/multiple_blocks/src/core_sw/Registry 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/core_sw/Registry 2012-05-22 20:50:11 UTC (rev 1930)
@@ -21,6 +21,7 @@
namelist logical sw_model config_wind_stress false
namelist logical sw_model config_bottom_drag false
namelist real sw_model config_apvm_upwinding 0.5
+namelist integer sw_model config_num_halos 2
namelist character io config_input_name grid.nc
namelist character io config_output_name output.nc
namelist character io config_restart_name restart.nc
Modified: branches/omp_blocks/multiple_blocks/src/framework/Makefile
===================================================================
--- branches/omp_blocks/multiple_blocks/src/framework/Makefile 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/framework/Makefile 2012-05-22 20:50:11 UTC (rev 1930)
@@ -16,6 +16,7 @@
mpas_hash.o \
mpas_sort.o \
mpas_block_decomp.o \
+ mpas_block_creator.o \
mpas_dmpar.o \
mpas_io.o \
mpas_io_streams.o \
@@ -51,11 +52,13 @@
mpas_block_decomp.o: mpas_grid_types.o mpas_hash.o mpas_configure.o
+mpas_block_creator.o: mpas_dmpar.o mpas_hash.o mpas_sort.o mpas_configure.o
+
mpas_io.o: mpas_dmpar_types.o
mpas_io_streams.o: mpas_attlist.o mpas_grid_types.o mpas_timekeeping.o mpas_io.o
-mpas_io_input.o: mpas_grid_types.o mpas_dmpar.o mpas_block_decomp.o mpas_sort.o mpas_configure.o mpas_timekeeping.o mpas_io_streams.o $(ZOLTANOBJ)
+mpas_io_input.o: mpas_grid_types.o mpas_dmpar.o mpas_block_decomp.o mpas_block_creator.o mpas_sort.o mpas_configure.o mpas_timekeeping.o mpas_io_streams.o $(ZOLTANOBJ)
mpas_io_output.o: mpas_grid_types.o mpas_dmpar.o mpas_sort.o mpas_configure.o mpas_io_streams.o
Added: branches/omp_blocks/multiple_blocks/src/framework/mpas_block_creator.F
===================================================================
--- branches/omp_blocks/multiple_blocks/src/framework/mpas_block_creator.F (rev 0)
+++ branches/omp_blocks/multiple_blocks/src/framework/mpas_block_creator.F 2012-05-22 20:50:11 UTC (rev 1930)
@@ -0,0 +1,500 @@
+module mpas_block_creator
+
+ use mpas_dmpar
+ use mpas_dmpar_types
+ use mpas_block_decomp
+ use mpas_hash
+ use mpas_sort
+ use mpas_grid_types
+ use mpas_configure
+
+ contains
+
+ subroutine mpas_block_creator_setup_blocks_and_0halo_cells(domain, indexToCellIDField, cellList, blockID, blockStart, blockCount)!{{{
+
+ type (domain_type), pointer :: domain
+ type (block_type), pointer :: block
+ type (field1dInteger), pointer :: indexToCellIDField
+ integer, dimension(:), intent(in) :: cellList
+ integer, dimension(:), intent(in) :: blockID
+ integer, dimension(:), intent(in) :: blockStart
+ integer, dimension(:), intent(in) :: blockCount
+
+ integer :: nHalos
+ type (block_type), pointer :: blockCursor
+ type (field1dInteger), pointer :: fieldCursor
+
+ integer :: i, iHalo
+ integer :: nBlocks
+
+ nBlocks = size(blockID)
+ nHalos = config_num_halos
+
+ allocate(domain % blocklist)
+ block => domain % blocklist
+ nullify(block % next)
+
+ allocate(indexToCellIDField)
+ nullify(indexToCellIDField % next)
+
+ blockCursor => block
+ fieldCursor => indexToCellIDField
+ do i = 1, nBlocks
+ blockCursor % blockID = blockID(i)
+ blockCursor % localBlockID = i - 1
+ blockCursor % domain => domain
+
+ fieldCursor % block => blockCursor
+ fieldCursor % dimSizes(1) = blockCount(i)
+
+ call mpas_dmpar_init_mulithalo_exchange_list(fieldCursor % sendList, nHalos)
+ call mpas_dmpar_init_mulithalo_exchange_list(fieldCursor % recvList, nHalos)
+ call mpas_dmpar_init_mulithalo_exchange_list(fieldCursor % copyList, nHalos)
+
+ allocate(fieldCursor % array(fieldCursor % dimSizes(1)))
+ fieldCursor % array(1:fieldCursor % dimSizes(1)) = cellList(blockStart(i)+1:blockStart(i)+blockCount(i))
+
+ if(i < nBlocks) then
+ allocate(blockCursor % next)
+ allocate(fieldCursor % next)
+
+ blockCursor => blockCursor % next
+ fieldCursor => fieldCursor % next
+ end if
+
+ nullify(blockCursor % next)
+ nullify(fieldCursor % next)
+ end do
+ end subroutine mpas_block_creator_setup_blocks_and_0halo_cells!}}}
+
+ subroutine mpas_block_creator_build_0halo_cell_fields(indexToCellIDBlock, nEdgesOnCellBlock, cellsOnCellBlock, indexToCellID_0Halo, nEdgesOnCell_0Halo, cellsOnCell_0Halo)!{{{
+ type(field1dInteger), pointer :: indexToCellIDBlock !< Input: Block of read in indexToCellID field
+ type(field1dInteger), pointer :: nEdgesOnCellBlock !< Input: Block of read in nEdgesOnCell field
+ type(field2dInteger), pointer :: cellsOnCellBlock !< Input: Block of read in cellsOnCell field
+
+ type(field1dInteger), pointer :: indexToCellID_0Halo !< Input: 0-Halo indices for indexToCellID field
+ type(field1dInteger), pointer :: nEdgesOnCell_0Halo !< Output: nEdgesOnCell field for 0-Halo cells
+ type(field2dInteger), pointer :: cellsOnCell_0Halo !< Output: cellsOnCell field for 0-Halo cells
+
+ type(field1dInteger), pointer :: indexCursor, nEdgesCursor
+ type(field2dInteger), pointer :: cellsOnCellCursor
+
+ integer, dimension(:), pointer :: sendingHaloLayers
+
+ integer :: nCellsInBlock, maxEdges, nHalos
+ integer :: i, iHalo
+
+ nHalos = size(indexToCellID_0Halo % sendList % halos)
+
+ allocate(sendingHaloLayers(1))
+ sendingHaloLayers(1) = 1
+
+ maxEdges = cellsOnCellBlock % dimSizes(1)
+
+ write(6,*) 'building exch list'
+ call mpas_dmpar_get_exch_list(1, indexToCellIDBlock, indexToCellID_0Halo)
+
+ allocate(nEdgesOnCell_0Halo)
+! nullify(nEdgesOncell_0Halo % next)
+
+ allocate(cellsOnCell_0Halo)
+! nullify(cellsOnCell_0Halo % next)
+
+ write(6,*) 'Setup fields'
+ indexCursor => indexToCellID_0Halo
+ nEdgesCursor => nEdgesOnCell_0Halo
+ cellsOnCellCursor => cellsOnCell_0Halo
+ do while(associated(indexCursor))
+ nCellsInBlock = indexCursor % dimSizes(1)
+
+ nEdgesCursor % block => indexCursor % block
+ cellsOnCellCursor % block => indexCursor % block
+
+ nEdgesCursor % dimSizes(1) = nCellsInBlock
+ cellsOnCellCursor % dimSizes(1) = maxEdges
+ cellsOnCellCursor % dimSizes(2) = nCellsInBlock
+
+ nEdgesCursor % sendList => indexCursor % sendList
+ nEdgesCursor % recvList => indexCursor % recvList
+ nEdgesCursor % copyList => indexCursor % copyList
+ cellsOnCellCursor % sendList => indexCursor % sendList
+ cellsOnCellCursor % recvList => indexCursor % recvList
+ cellsOnCellCursor % copyList => indexCursor % copyList
+
+ allocate(nEdgesCursor % array(nEdgesCursor % dimSizes(1)))
+ allocate(cellsOnCellCursor % array(cellsOnCellCursor % dimSizes(1), cellsOnCellCursor % dimSizes(2)))
+
+ indexCursor => indexCursor % next
+ if(associated(indexCursor)) then
+ allocate(nEdgesCursor % next)
+ allocate(cellsOnCellCursor % next)
+
+ nEdgesCursor => nEdgesCursor % next
+ cellsOnCellCursor => cellsOnCellCursor % next
+
+ end if
+
+ nullify(nEdgesCursor % next)
+ nullify(cellsOnCellCursor % next)
+ end do
+
+ write(6,*) 'communicate 1d field'
+ call mpas_dmpar_alltoall_field(nEdgesOnCellBlock, nEdgesOnCell_0Halo, sendingHaloLayers)
+ write(6,*) 'communicate 2d field'
+ call mpas_dmpar_alltoall_field(cellsOnCellBlock, cellsOnCell_0Halo, sendingHaloLayers)
+
+ end subroutine mpas_block_creator_build_0halo_cell_fields!}}}
+
+!***********************************************************************
+!
+! routine mpas_get_halo_cells_and_exchange_lists
+!
+!> \brief Determines cell indices for each halo layer, and builds exchange lists
+!> \author Doug Jacobsen
+!> \date 04/30/12
+!> \version SVN:$Id$
+!> \details
+!> This routine builds the field indexToCellID_nHalos, which is an array of nHalos linked lists.
+!> Each index in indexToCellID_nHalos represnts a linked list of cells in a given halo.
+!> It creates the exchange lists for cells, and places them in the block structure.
+!> In order to call this routine, there are some assumptions made.
+!> The first assumption is that the 1 index of each array is setup correctly,
+!> ie block pointers are valid, dimSizes are valid, next pointers are valid, ets
+!> The second assumption is that the arrays in each field are allocated and full with their appropriate information.
+!> These assumptions lead to the conclusion that the 0 halo has to be properly setup prior to calling this routine.
+!
+!-----------------------------------------------------------------------
+
+! subroutine mpas_get_halo_cells_and_exchange_lists(indexToCellID_0Halo, nEdgesOnCell_0Halo, cellsOnCell_0Halo, indexToCellID_nHalos, nEdgesOnCell_nHalos, cellsOnCell_nHalos)!{{{
+
+! type (field1dInteger), pointer :: indexToCellID_0Halo
+! type (field1dInteger), pointer :: nEdgesOnCell_0Halo
+! type (field2dInteger), pointer :: cellsOnCell_0Halo
+
+! type (field1dInteger), dimension(:), pointer :: indexToCellID_nHalos
+! type (field1dInteger), dimension(:), pointer :: nEdgesOnCell_nHalos
+! type (field2dInteger), dimension(:), pointer :: cellsOnCell_nHalos
+
+! type (field1dInteger), pointer :: indexToCellID_ptr, indexToCellID_Halo_ptr
+! type (field1dInteger), pointer :: nEdgesOnCell_ptr, nEdgesOnCell_Halo_ptr
+! type (field2dInteger), pointer :: cellsOnCell_ptr, cellsOnCell_Halo_ptr
+
+! type (field0dInteger), pointer :: offSetField
+! type (field0dInteger), pointer :: offSet_ptr
+
+! type (dm_info), pointer :: dminfo
+! type (block_type), pointer :: block_ptr
+
+! type (graph) :: block_graph, block_graph_with_halo
+
+! type (mpas_exchange_list), pointer :: exchListPtr
+
+! integer :: nHalos
+! integer :: nCellsInBlock, nCellsInHalo, maxEdges
+! integer :: indexShift, exchListOffSet
+! integer :: haloStart, haloEnd
+! integer :: iHalo, i, j, k
+
+! nHalos = config_num_halos
+
+! dminfo => indexToCellID_0Halo % block % domain % dminfo
+
+! maxEdges = cellsOnCell_0Halo % dimSizes(1)
+! allocate(indexToCellID_nHalos(nHalos))
+! allocate(nEdgesOnCell_nHalos(nHalos))
+! allocate(cellsOnCell_nHalos(nHalos))
+! allocate(offSetField)
+
+! block_ptr => indexToCellID_0Halo % block
+! offSet_ptr => offSetField
+
+! do while(associated(block_ptr))
+! allocate(block_ptr % parinfo)
+! call mpas_dmpar_init_mulithalo_exchange_list(block_ptr % parinfo % cellsToSend, nHalos)
+! call mpas_dmpar_init_mulithalo_exchange_list(block_ptr % parinfo % cellsToRecv, nHalos)
+! call mpas_dmpar_init_mulithalo_exchange_list(block_ptr % parinfo % cellsToCopy, nHalos)
+
+! offSet_ptr % block => block_ptr
+! block_ptr => block_ptr % next
+! if(associated(block_ptr)) then
+! allocate(offSet_ptr % next)
+! offSet_ptr => offSet_ptr % next
+! end if
+! nullify(offSet_ptr % next)
+! end do
+
+! do iHalo = 1, nHalos
+! ! Setup block pointers for the next halo
+! indexToCellID_ptr => indexToCellID_0Halo
+! nEdgesOnCell_ptr => nEdgesOnCell_0Halo
+! cellsOnCell_ptr => cellsOnCell_0Halo
+
+! indexToCellID_Halo_ptr => indexToCellID_nHalos(iHalo)
+! nEdgesOnCell_Halo_ptr => nEdgesOnCell_nHalos(iHalo)
+! cellsOnCell_Halo_ptr => cellsOnCell_nHalos(iHalo)
+! do while (associated(indexToCellID_ptr))
+
+! indexToCellID_Halo_ptr % block => indexToCellID_ptr % block
+! nEdgesOnCell_Halo_ptr % block => nEdgesOnCell_ptr % block
+! cellsOnCell_Halo_ptr % block => cellsOnCell_ptr % block
+
+! indexToCellID_ptr => indexToCellID_ptr % next
+! nEdgesOnCell_ptr => nEdgesOnCell_ptr % next
+! cellsOnCell_ptr => cellsOnCell_ptr % next
+! if(associated(indexToCellID_ptr)) then
+! allocate(indexToCellID_Halo_ptr % next)
+! allocate(nEdgesOnCell_Halo_ptr % next)
+! allocate(cellsOnCell_Halo_ptr % next)
+! indexToCellID_Halo_ptr => indexToCellID_Halo_ptr % next
+! nEdgesOnCell_Halo_ptr => nEdgesOnCell_Halo_ptr % next
+! cellsOnCell_Halo_ptr => cellsOnCell_Halo_ptr % next
+! end if
+
+! nullify(indexTocellID_Halo_ptr % next)
+! nullify(nEdgesOnCell_Halo_ptr % next)
+! nullify(cellsOnCell_Halo_ptr % next)
+! end do
+
+! indexToCellID_ptr => indexToCellID_0Halo
+! nEdgesOnCell_ptr => nEdgesOnCell_0Halo
+! cellsOnCell_ptr => cellsOnCell_0Halo
+! offSet_ptr => offSetField
+! do while (associated(indexToCellID_ptr))
+! nCellsInBlock = indexToCellID_ptr % dimSizes(1)
+
+! ! Determine number of total cells in block and halos
+! do k = 1, iHalo-1
+! indexToCellID_Halo_ptr => indexToCellID_nHalos(k)
+! do while(associated(indexToCellID_Halo_ptr))
+! if(indexToCellID_Halo_ptr % block % blockID == indexToCellID_ptr % block % blockID) exit
+! indexToCellID_Halo_ptr => indexToCellID_Halo_ptr % next
+! end do
+! nCellsInBlock = nCellsInBlock + indexToCellID_Halo_ptr % dimSizes(1)
+! end do
+
+! ! Setup block graph, using owned and halo cells
+! offSet_ptr % scalar = nCellsInBlock
+! block_graph % nVertices = nCellsInBlock
+! block_graph % nVerticesTotal = nCellsInBlock
+! block_graph % maxDegree = maxEdges
+! block_graph % ghostStart = nCellsInBlock + 1
+
+! allocate(block_graph % vertexID(nCellsInBlock))
+! allocate(block_graph % nAdjacent(nCellsInBlock))
+! allocate(block_graph % adjacencyList(maxEdges, nCellsInBlock))
+
+! ! Add all owned cells to graph
+! indexShift = 0
+! block_graph % vertexID(indexShift+1:indexToCellID_ptr % dimSizes(1)) = indexToCellID_ptr % array(:)
+! block_graph % nAdjacent(indexShift+1:nEdgesOnCell_ptr % dimSizes(1)) = nEdgesOnCell_ptr % array(:)
+! block_graph % adjacencyList(:,indexShift+1:cellsOnCell_ptr % dimSizes(2)) = cellsOnCell_ptr % array(:,:)
+
+! ! Add all halo cells to graph
+! indexShift = indexShift + indexToCellID_ptr % dimSizes(1)
+! do k = 1, iHalo-1
+! indexToCellID_Halo_ptr => indexToCellID_nHalos(k)
+! nEdgesOnCell_Halo_ptr => nEdgesOnCell_nHalos(k)
+! cellsOnCell_Halo_ptr => cellsOnCell_nHalos(k)
+! do while(associated(indexToCellID_Halo_ptr))
+! if(indexToCellID_Halo_ptr % block % blockID == indexToCellID_ptr % block % blockID) exit
+! indexToCellID_Halo_ptr => indexToCellID_Halo_ptr % next
+! nEdgesOnCell_Halo_ptr => nEdgesOnCell_Halo_ptr % next
+! cellsOnCell_Halo_ptr => cellsOnCell_Halo_ptr % next
+! end do
+
+! block_graph % vertexID(indexShift+1:indexShift+indexToCellID_Halo_ptr % dimSizes(1)) = indexToCellID_Halo_ptr % array(:)
+! block_graph % nAdjacent(indexShift+1:indexShift+nEdgesOnCell_Halo_ptr % dimSizes(1)) = nEdgesOnCell_Halo_ptr % array(:)
+! block_graph % adjacencyList(:,indexShift+1:indexShift+cellsOnCell_Halo_ptr % dimSizes(2)) = cellsOnCell_Halo_ptr % array(:,:)
+! indexShift = indexShift + indexToCellID_Halo_ptr % dimSizes(1)
+! end do
+
+! ! Get a new block graph with the next halo layer added.
+! call mpas_block_decomp_add_halo(dminfo, block_graph, block_graph_with_halo)
+!
+! indexToCellID_Halo_ptr => indexToCellID_nHalos(iHalo)
+! nEdgesOnCell_Halo_ptr => nEdgesOnCell_nHalos(iHalo)
+! cellsOnCell_Halo_ptr => cellsOnCell_nHalos(iHalo)
+!
+! do while(associated(indexToCellID_Halo_ptr))
+!
+! if(indexToCellID_Halo_ptr % block % blockID == indexToCellID_ptr % block % blockID) exit
+!
+! indexToCellID_Halo_ptr => indexToCellID_Halo_ptr % next
+! nEdgesOnCell_Halo_ptr => nEdgesOnCell_Halo_ptr % next
+! cellsOnCell_Halo_ptr => cellsOnCell_Halo_ptr % next
+! end do
+
+! haloStart = block_graph_with_halo % nVertices
+! haloEnd = block_graph_with_halo % nVerticesTotal
+! nCellsInHalo = haloEnd - haloStart
+
+! indexToCellID_Halo_ptr % dimSizes(1) = nCellsInHalo
+! nEdgesOnCell_Halo_ptr % dimSizes(1) = nCellsInHalo
+! cellsOnCell_Halo_ptr % dimSizes(1) = maxEdges
+! cellsOnCell_Halo_ptr % dimSizes(2) = nCellsInHalo
+
+! allocate(indexToCellID_Halo_ptr % array(nCellsInHalo))
+! allocate(nEdgesOnCell_Halo_ptr % array(nCellsInHalo))
+! allocate(cellsOnCell_Halo_ptr % array(maxEdges, nCellsInHalo))
+
+! indexToCellID_Halo_ptr % array(:) = block_graph_with_halo % vertexID(haloStart+1:haloEnd)
+
+! deallocate(block_graph % vertexID)
+! deallocate(block_graph % nAdjacent)
+! deallocate(block_graph % adjacencyList)
+! deallocate(block_graph_with_halo % vertexID)
+! deallocate(block_graph_with_halo % nAdjacent)
+! deallocate(block_graph_with_halo % adjacencyList)
+! indexToCellID_ptr => indexToCellID_ptr % next
+! nEdgesOnCell_ptr => nEdgesOnCell_ptr % next
+! cellsOnCell_ptr => cellsOnCell_ptr % next
+! offSet_ptr => offSet_ptr % next
+! end do
+
+! indexToCellID_Halo_ptr => indexToCellID_nHalos(iHalo)
+! nEdgesOnCell_Halo_ptr => nEdgesOnCell_nHalos(iHalo)
+! cellsOnCell_Halo_ptr => cellsOnCell_nHalos(iHalo)
+
+! call mpas_dmpar_get_exch_list(iHalo, indexToCellID_0Halo, indexToCellID_Halo_ptr)
+
+! call mpas_dmpar_alltoall_field(indexToCellID_0Halo, indexToCellID_Halo_ptr)
+! call mpas_dmpar_alltoall_field(nEdgesOnCell_0Halo, nEdgesOnCell_Halo_ptr)
+! call mpas_dmpar_alltoall_field(cellsOnCell_0Halo, cellsOnCell_Halo_ptr)
+
+! indexToCellID_ptr => indexToCellID_0Halo
+! indexToCellID_Halo_ptr => indextoCellID_nHalos(iHalo)
+! offSet_ptr => offSetField
+! do while(associated(indexToCellID_ptr))
+! ! Offset destination indices for recieves and local copies.
+! exchListPtr => indexToCellID_Halo_ptr % recvList % halos(iHalo) % exchList
+! do i = 1, exchListPtr % nList
+! exchListPtr % destList(i) = exchListPtr % destList(i) + offSet_ptr % scalar
+! end do
+
+! exchListPtr => indexToCellID_Halo_ptr % copyList % halos(iHalo) % exchList
+! do i = 1, exchListPtr % nList
+! exchListPtr % destList(i) = exchListPtr % destList(i) + offSet_ptr % scalar
+! end do
+
+! indexToCellID_ptr % block % parinfo % cellsToSend % halos(iHalo) % exchList => indexToCellID_ptr % sendList % halos(iHalo) % exchList
+! indexToCellID_ptr % block % parinfo % cellsToRecv % halos(iHalo) % exchList => indexToCellID_Halo_ptr % recvList % halos(iHalo) % exchList
+! indexToCellID_ptr % block % parinfo % cellsToCopy % halos(iHalo) % exchList => indexToCellID_Halo_ptr % copyList % halos(iHalo) % exchList
+
+! nullify(indexToCellID_ptr % sendList % halos(iHalo) % exchList)
+! nullify(indexToCellID_ptr % recvList % halos(iHalo) % exchList)
+! nullify(indexToCellID_ptr % copyList % halos(iHalo) % exchList)
+
+! indexToCellID_ptr => indexToCellID_ptr % next
+! indextoCellID_Halo_ptr => indexToCellID_Halo_ptr % next
+! offSet_ptr => offSet_ptr % next
+! end do
+
+! end do ! iHalo loop over nHalos
+
+! end subroutine mpas_get_halo_cells_and_exchange_lists !}}}
+
+!***********************************************************************
+!
+! routine mpas_get_vertex_ids_and_exchange_lists
+!
+!> \brief Determines vertex indices for each halo layer, and builds exchange lists
+!> \author Doug Jacobsen
+!> \date 05/01/12
+!> \version SVN:$Id$
+!> \details
+!> This routine fills in the arrays for the indexToVertexID_0Halo, and indexToVertexID_nHalos
+!> indexToVertexID_0Halo represents all vertices in the 0 halo, while indexToVertexID_nHalos represnts
+!> the vertex id's for all vertices in all other halos. It is an array of linked lists where each
+!> index represents the linked list of vertex ids at that halo layer.
+!> It creates the exchange lists for vertices, and places them in the block structure.
+!> In order to call this routine, there are some assumptions made.
+!> The first assumption is that the 1 index of each array is setup correctly,
+!> ie block pointers are valid, dimSizes are valid, next pointers are valid, ets
+!> The second assumption is that the arrays in each field are allocated and full with their appropriate information.
+!> These assumptions lead to the conclusion that the 0 halo has to be properly setup prior to calling this routine.
+!
+!-----------------------------------------------------------------------
+
+! subroutine mpas_get_vertex_ids_and_exchange_lists(dminfo, nHalos, maxEdges, vertexDegree, indexToCellID_0Halo, nEdgesOnCell_0Halo, verticesOnCell_0Halo, cellsOnVertex_0Halo, indexToCellID_nHalos, indexToVertexID_0Halo, indexToVertexID_nHalos)!{{{
+! type (dm_info), intent(in) :: dminfo
+! integer, intent(in) :: nHalos
+! integer, intent(in) :: maxEdges
+! integer, intent(in) :: vertexDegree
+
+! type(field1dInteger), pointer :: indexToCellID_0Halo
+! type(field1dInteger), pointer :: nEdgesOnCell_0Halo
+! type(field1dInteger), pointer :: verticesOnCell_0Halo
+! type(field1dInteger), pointer :: cellsOnVertex_0Halo
+! type(field1dInteger), dimension(:), pointer :: indexToCellID_nHalos
+
+! type(field1dInteger), pointer :: indexToVertexID_0Halo
+! type(field1dInteger), dimension(:), pointer :: indexToVertexID_nHalos
+
+! type(field1dInteger), dimension(:), pointer :: cellsOnVertex_nHalos
+! type(field1dInteger), dimension(:), pointer :: nEdgesOnCell_nHalos
+
+! type(field1dInteger), pointer :: indexToCellID_ptr, nEdgesOnCell_ptr, verticesOnCell_ptr, cellsOnVertex_ptr, indexToVertexID_ptr
+! type(field1dInteger), pointer :: indexToCellID_Halo_ptr, indexToVertexID_Halo_ptr
+
+! integer, dimension(:), pointer :: all_vertices_in_block
+! integer :: nCellsInBlock
+! integer :: nVerticesInBlock
+! integer :: nVerticesInHalo, haloStart, haloEnd
+
+! type (graph) :: block_graph, block_graph_with_halo
+
+! integer :: iCell, iVertex
+! integer :: i, j, k, iHalo
+
+! allocate(indexToVertexID_0Halo)
+! allocate(indexToVertexID_nHalos(nHalos+1)) ! 1 more halo than cells
+! allocate(cellsOnVertex_nHalos(nHalos+1)) ! 1 more halo than cells
+! allocate(nEdgesOnCell_nHalos(nHalos))
+
+! ! Build the 0 and 1 halos
+! indexToCellID_ptr => indexToCellID_0Halo
+! nEdgesOnCell_ptr => nEdgesOnCell_0Halo
+! verticesOnCell_ptr => verticesOnCell_0Halo
+! cellsOnVertex_ptr => cellsOnVertex_0Halo
+! indexToVertexID_ptr => indexToVertexID_0Halo
+! indexToVertexID_Halo_ptr => indexToVertexID_nHalos(1)
+! do while(associated(indexToCellID_ptr))
+! nCellsInBlock = indexToCellID_ptr % dimSizes(1)
+
+! call mpas_block_decomp_all_edges_in_block(maxEdges, nCellsInBlock, nEdgesOnCell_ptr % array, verticesOnCell_ptr % array, nVerticesInBlock, all_vertices_in_block)
+! call mpas_block_decomp_partitioned_edge_list(nCellsInBlock, indexToCellID_ptr % array, vertexDegree, nVerticesInBlock, cellsOnVertex_ptr % array, all_vertices_in_block, haloStart)
+
+! call mpas_block_decomp_all_edges_in_block(maxEdges, block_graph_2Halo % nVerticesTotal, block_graph_2Halo % nAdjacent, &
+! verticesOnCell_2Halo, nlocal_vertices, local_vertex_list)
+
+! call mpas_block_decomp_partitioned_edge_list(nOwnCells, &
+! block_graph_2Halo % vertexID(1:nOwnCells), &
+! vertexDegree, nlocal_vertices, cellsOnVertex_2Halo, local_vertex_list, ghostVertexStart)
+
+! indexToVertexID_ptr % block => indexToCellID_ptr % block
+! indexToVertexID_ptr % dimSizes(1) = haloStart
+! allocate(indexToVertexID_ptr % array(indexToVertexID_ptr % dimSizes(1)))
+
+! indexToVertexID_ptr % array(:) = all_vertices_in_block(1:haloStart)
+
+! indexToVertexID_Halo_ptr % block => indexToCellID_Halo_ptr % block
+! indexToVertexID_Halo_ptr % dimSizes(1) = nVerticesInBlock - haloStart
+! allocate(indexToVertexID_Halo_ptr % array(indexToVertexID_Halo_ptr % dimSizes(1)))
+
+! indexToVertexID_Halo_ptr % array(:) = all_vertices_in_block(haloStart+1:nVerticesInBlock)
+
+! indexToCellID_ptr => indexToCellID_ptr % next
+! verticesOnCell_ptr => verticesOnCell_ptr % next
+! cellsOnVertex_ptr => cellsOnVertex_ptr % next
+! if(associated(indexToCellID_ptr)) then
+! allocate(indexToVertexID_ptr % next)
+! indexToVertexID_ptr => indexToVertexID_ptr % next
+! end if
+
+! nullify(indexToVertexID_ptr % next)
+! end do
+
+! end subroutine mpas_get_vertex_ids_and_exchange_lists!}}}
+
+
+end module mpas_block_creator
Modified: branches/omp_blocks/multiple_blocks/src/framework/mpas_block_decomp.F
===================================================================
--- branches/omp_blocks/multiple_blocks/src/framework/mpas_block_decomp.F 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/framework/mpas_block_decomp.F 2012-05-22 20:50:11 UTC (rev 1930)
@@ -6,20 +6,6 @@
use mpas_sort
use mpas_grid_types
- interface mpas_link_exchange_list_field
- module procedure mpas_link_exchange_list_field1d_integer
- module procedure mpas_link_exchange_list_field2d_integer
- module procedure mpas_link_exchange_list_field3d_integer
- module procedure mpas_link_exchange_list_field2d_real
- module procedure mpas_link_exchange_list_field3d_real
- end interface
-
- private :: mpas_link_exchange_list_field1d_integer
- private :: mpas_link_exchange_list_field2d_integer
- private :: mpas_link_exchange_list_field3d_integer
- private :: mpas_link_exchange_list_field1d_real
- private :: mpas_link_exchange_list_field2d_real
-
type graph
integer :: nVerticesTotal
integer :: nVertices, maxDegree
@@ -543,906 +529,4 @@
deallocate(block_local_id_list)
end subroutine mpas_finish_block_proc_list!}}}
- subroutine mpas_get_exchange_lists(dminfo, ownedListField, ownedDecomposed, neededListField, neededDecomposed, offSetField)!{{{
- type (dm_info), intent(in) :: dminfo !< Input: Domain information
- type (field1dInteger), pointer :: ownedListField !< Input/Output: pointer to the field which contains owned elements for exchange list.
- logical, intent(in) :: ownedDecomposed !< Input: logical flag determining if the ownedList is decomposed using block_decomp or not.
- type (field1dInteger), pointer :: neededListField !< Input/Output: pointer to a field which contains needed elements for exchange list.
- logical, intent(in) :: neededDecomposed !< Input: logical flag determining if the neededList is decomposed using block_decomp or not.
- type (field0dInteger), pointer, optional :: offSetField
-
- type (field2dInteger), pointer :: ownedListSorted, sorted_field_ptr
-
- type (field0dInteger), pointer :: offset_ptr
- type (field1dInteger), pointer :: field_ptr
- type (exchange_list), pointer :: exchListPtr, exchListPtr2
-
- integer :: i, j, k, n, iBlock, iElement, iElementInBlock, elementShift
- integer :: nBlocksNeeded, nBlocksOwned
- integer :: nBlocksNeededMax, nBlocksOwnedMax
- integer :: totalBlocksOwned, totalBlocksNeeded
- integer :: nNeededElements, nNeededElementsMax
- integer :: nOwnedElementsMax, nOwnedElements
- integer :: recvNeighbor, sendNeighbor
- integer :: current_proc, nMesgRecv, nMesgSend
- integer :: localBlockID, globalBlockID, owningProc
- integer :: currentProc, offSet
-
- integer :: mpi_ierr, mpi_rreq, mpi_sreq
-
- integer, dimension(:), pointer :: numToSend, numToRecv, numToCopy
-
- integer, dimension(:), pointer :: ownerListIn, ownerBlockListIn, ownerListOut, ownerBlockListOut
- integer, dimension(:,:), pointer :: elementRecipients
-
- ! Setup exchange lists on ownedList to be built later.
- ! Really only sendList will be setup
- field_ptr => ownedListField
- do while(associated(field_ptr))
- allocate(field_ptr % sendList(1))
- allocate(field_ptr % recvList(1))
- allocate(field_ptr % copyList(1))
- nullify(field_ptr % sendList(1) % next)
- nullify(field_ptr % recvList(1) % next)
- nullify(field_ptr % copyList(1) % next)
-
- field_ptr => field_ptr % next
- end do
-
- ! Setup exchange lists on neededList to be build later
- ! Really only recvList and copyList will be setup
- field_ptr => neededListField
- do while(associated(field_ptr))
- allocate(field_ptr % sendList(1))
- allocate(field_ptr % recvList(1))
- allocate(field_ptr % copyList(1))
- nullify(field_ptr % sendList(1) % next)
- nullify(field_ptr % recvList(1) % next)
- nullify(field_ptr % copyList(1) % next)
-
- field_ptr => field_ptr % next
- end do
-
- if(ownedDecomposed) then
- call mpas_get_blocks_per_proc(dminfo, dminfo % my_proc_id, nBlocksOwned)
- totalBlocksOwned = total_blocks
- else
- nBlocksOwned = 1
- totalBlocksOwned = dminfo % nProcs
- end if
-
- if(neededDecomposed) then
- call mpas_get_blocks_per_proc(dminfo, dminfo % my_proc_id, nBlocksNeeded)
- totalBlocksNeeded = total_blocks
- else
- nBlocksNeeded = 1
- totalBlocksNeeded = dminfo % nProcs
- end if
-
- ! Determine number of blocks on current processor, and maximum number of blocks on any processor
- call mpas_dmpar_max_int(dminfo, nBlocksNeeded, nBlocksNeededMax)
- call mpas_dmpar_max_int(dminfo, nBlocksOwned, nBlocksOwnedMax)
-
- allocate(numToSend(totalBlocksNeeded))
- allocate(numToRecv(totalBlocksOwned))
- allocate(numToCopy(totalBlocksOwned))
-
- allocate(ownedListSorted)
- field_ptr => ownedListField
- sorted_field_ptr => ownedListSorted
-
- ! sort owned elements, and link to block structure.
- nOwnedElementsMax = 0
- do while (associated(field_ptr))
- allocate(sorted_field_ptr % array(2, field_ptr % dimSizes(1)))
-
- nOwnedElementsMax = max(nOwnedElementsMax, field_ptr % dimSizes(1))
-
- sorted_field_ptr % block => field_ptr % block
- sorted_field_ptr % dimSizes(1) = 2
- sorted_field_ptr % dimSizes(2) = field_ptr % dimSizes(1)
- sorted_field_ptr % sendList => field_ptr % sendList
- sorted_field_ptr % recvList => field_ptr % recvList
- sorted_field_ptr % copyList => field_ptr % copyList
-
- do i = 1, field_ptr % dimSizes(1)
- sorted_field_ptr % array(1, i) = field_ptr % array(i)
- sorted_field_ptr % array(2, i) = i
- end do
-
- call quicksort(field_ptr % dimSizes(1), sorted_field_ptr % array)
-
- field_ptr => field_ptr % next
- if(associated(field_ptr)) then
- allocate(sorted_field_ptr % next)
- sorted_field_ptr => sorted_field_ptr % next
- else
- nullify(sorted_field_ptr % next)
- end if
- end do
-
-
- ! Determine number of local needed elements.
- field_ptr => neededListField
- nNeededElements = 0
-
- do while(associated(field_ptr))
- nNeededElements = nNeededElements + field_ptr % dimSizes(1)
- field_ptr => field_ptr % next
- end do
-
- ! Determine number of maximum needed elements
- call mpas_dmpar_max_int(dminfo, nNeededElements, nNeededElementsMax)
-
- allocate(ownerListIn(nNeededElementsMax))
- allocate(ownerBlockListIn(nNeededElementsMax))
- allocate(ownerListOut(nNeededElementsMax))
- allocate(ownerBlockListOut(nNeededElementsMax))
- allocate(elementRecipients(2,nOwnedElementsMax))
-
- field_ptr => neededListField
- iElement = 1
- do while(associated(field_ptr))
- do i = 1, field_ptr % dimSizes(1)
- ownerListIn(iElement) = field_ptr % array(i)
- ownerBlockListIn(iElement) = field_ptr % block % blockID
- iElement = iElement + 1
- end do
- field_ptr => field_ptr % next
- end do
-
- recvNeighbor = mod(dminfo % my_proc_id + dminfo % nprocs - 1, dminfo % nprocs)
- sendNeighbor = mod(dminfo % my_proc_id + 1, dminfo % nprocs)
- nMesgRecv = nNeededElements
-
- ! Build send lists, and determine owning block id's for needed elements
- do i = 1, dminfo % nProcs
- ownerBlockListOut = ownerBlockListIn
- currentProc = mod(dminfo % my_proc_id + dminfo % nprocs - i + 1, dminfo % nprocs)
-
- field_ptr => ownedListField
- sorted_field_ptr => ownedListSorted
- do while (associated(field_ptr))
- elementRecipients = -1
- numToSend = 0
- nOwnedElements = field_ptr % dimSizes(1)
-
- do j = 1, nMesgRecv
- if(ownerListIn(j) > 0) then
- k = mpas_binary_search(sorted_field_ptr % array, 2, 1, nOwnedElements, ownerListIn(j))
- if(k <= nOwnedElements) then
- ownerListOut(j) = -1 * sorted_field_ptr % block % blockID
- ownerListIn(j) = -1 * sorted_field_ptr % block % blockID
- numToSend(ownerBlockListIn(j) + 1) = numToSend(ownerBlockListIn(j) + 1) + 1
- elementRecipients(1,sorted_field_ptr % array(2,k)) = ownerBLockListIn(j)
- elementRecipients(2,sorted_field_ptr % array(2,k)) = numToSend(ownerblockListIn(j)+1)
- else
- ownerListOut(j) = ownerListIn(j)
- end if
- else
- ownerListOut(j) = ownerListIn(j)
- end if
- end do ! j loop over nMesgRecv
-
-! write(6,*) 'numToSend'
-! write(6,*) numToSend
-
-! write(6,*) 'elementRecipients'
-! do iElement = 1, nOwnedElements
-! write(6,*) elementRecipients(:,iElement)
-! end do
-
- ! Find end of send list
- exchListPtr => field_ptr % sendList(1)
- exchListPtr2 => field_ptr % sendList(1) % next
- do while(associated(exchListPtr2))
- exchListPtr => exchListPtr2
- exchListPtr2 => exchListPtr2 % next
- end do
-
- do j = 1, totalBlocksNeeded
- if(numToSend(j) > 0) then
- allocate(exchListPtr % next)
- exchListPtr => exchListPtr % next
- nullify(exchListPtr % next)
-
- exchListPtr % procID = currentProc
- exchListPtr % blockID = j - 1
- exchListPtr % nlist = numToSend(j)
-
- allocate(exchListPtr % list(numToSend(j)))
- exchListPtr % list = -1
-
- do iElement = 1, nOwnedElements
- if(elementRecipients(1,iElement) == j-1) then
- exchListPtr % list(elementRecipients(2,iElement)) = iElement
- end if
- end do
- end if
- end do ! j loop over totalBlocksNeeded
-
- field_ptr => field_ptr % next
- sorted_field_ptr => sorted_field_ptr % next
- end do ! associated loop over sorted_field_ptr
-
- !Send messages to next processor, and recieve next batch of elements to process
- 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)
- call MPI_Irecv(ownerBlockListIn, nMesgRecv, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
- call MPI_Isend(ownerBlockListOut, 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 ! i loop over nProcs
-
- field_ptr => neededListField
- do while(associated(field_ptr))
- offSet = 0
- if(present(offSetField)) then
- offSet_ptr => offSetfield
- do while(associated(offSet_ptr))
- if(offSet_ptr % block % blockID == field_ptr % block % blockID) then
- exit
- end if
- offSet_ptr => offSet_ptr % next
- end do
-
- offSet = offSet_ptr % scalar
- end if
-
- numToRecv = 0
- do i = 1, nMesgRecv
- if(ownerBlockListIn(i) == field_ptr % block % blockID) then
- numToRecv(abs(ownerListIn(i))+1) = numToRecv(abs(ownerListIn(i))+1) + 1
- end if
- end do
-
- do iBlock = 1, totalBlocksOwned
- if(numToRecv(iBlock) > 0) then
- if(.not.ownedDecomposed) then
- owningProc = iBlock - 1
- else
- call mpas_get_owning_proc(dminfo, iBlock - 1, owningProc)
- end if
-
- ! Determine if copyList or recvList should be used
- if(owningProc == dminfo % my_proc_id) then
- exchListPtr => field_ptr % copyList(1)
- else
- exchListPtr => field_ptr % recvList(1)
- end if
-
- ! Find end of exchange list
- exchListPtr2 => exchListPtr % next
- do while(associated(exchListPtr2))
- exchListPtr => exchListPtr2
- exchListPtr2 => exchListPtr2 % next
- end do
-
- allocate(exchListPtr % next)
- exchListPtr => exchListPtr % next
- nullify(exchListPtr % next)
-
- exchListPtr % procID = owningProc
- exchListPtr % blockID = iBlock - 1
- exchListPtr % nList = numToRecv(iBlock)
- allocate(exchListPtr % list(numToRecv(iBlock)))
-
- iElement = 0
- iElementInBlock = 0
- do i = 1, nMesgRecv
- if(ownerBlockListIn(i) == field_ptr % block % blockID) then
- iElementInBlock = iElementInBlock + 1
- end if
- if(ownerBlockListIn(i) == field_ptr % block % blockID .and. abs(ownerListIn(i)) == iBlock-1) then
- iElement = iElement + 1
-
- exchListPtr % list(iElement) = iElementInBlock + offSet
- end if
- end do
- end if
- end do
-
- field_ptr => field_ptr % next
- end do
-
- deallocate(ownerListIn)
- deallocate(ownerBlockListIn)
- deallocate(ownerListOut)
- deallocate(ownerBlockListOut)
- deallocate(elementRecipients)
-
- end subroutine mpas_get_exchange_lists!}}}
-
- subroutine mpas_link_exchange_list_field1d_integer(sendListField, recvListField, ownedListField, neededListField)!{{{
- type (field1dInteger), pointer :: sendListField
- type (field1dInteger), pointer :: recvListField
- type (field1dInteger), pointer :: ownedListField
- type (field1dInteger), pointer :: neededListField
-
- type (field1dInteger), pointer :: exchFieldPtr
- type (field1dInteger), pointer :: dataFieldPtr
-
- exchFieldPtr => sendListField
- dataFieldPtr => ownedListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % sendList(1))
- nullify(dataFieldPtr % sendList(1) % next)
- dataFieldPtr % sendList(1) % next => exchFieldPtr % sendList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
- exchFieldPtr => recvListField
- dataFieldPtr => neededListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % recvList(1))
- allocate(dataFieldPtr % copyList(1))
- nullify(dataFieldPtr % recvList(1) % next)
- nullify(dataFieldPtr % copyList(1) % next)
- dataFieldPtr % recvList(1) % next => exchFieldPtr % recvList(1) % next
- dataFieldPtr % copyList(1) % next => exchFieldPtr % copyList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
-
- end subroutine mpas_link_exchange_list_field1d_integer!}}}
-
- subroutine mpas_link_exchange_list_field2d_integer(sendListField, recvListField, ownedListField, neededListField)!{{{
- type (field1dInteger), pointer :: sendListField
- type (field1dInteger), pointer :: recvListField
- type (field2dInteger), pointer :: ownedListField
- type (field2dInteger), pointer :: neededListField
-
- type (field1dInteger), pointer :: exchFieldPtr
- type (field2dInteger), pointer :: dataFieldPtr
-
- exchFieldPtr => sendListField
- dataFieldPtr => ownedListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % sendList(1))
- nullify(dataFieldPtr % sendList(1) % next)
- dataFieldPtr % sendList(1) % next => exchFieldPtr % sendList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
- exchFieldPtr => recvListField
- dataFieldPtr => neededListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % recvList(1))
- allocate(dataFieldPtr % copyList(1))
- nullify(dataFieldPtr % recvList(1) % next)
- nullify(dataFieldPtr % copyList(1) % next)
- dataFieldPtr % recvList(1) % next => exchFieldPtr % recvList(1) % next
- dataFieldPtr % copyList(1) % next => exchFieldPtr % copyList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
-
- end subroutine mpas_link_exchange_list_field2d_integer!}}}
-
- subroutine mpas_link_exchange_list_field3d_integer(sendListField, recvListField, ownedListField, neededListField)!{{{
- type (field1dInteger), pointer :: sendListField
- type (field1dInteger), pointer :: recvListField
- type (field3dInteger), pointer :: ownedListField
- type (field3dInteger), pointer :: neededListField
-
- type (field1dInteger), pointer :: exchFieldPtr
- type (field3dInteger), pointer :: dataFieldPtr
-
- exchFieldPtr => sendListField
- dataFieldPtr => ownedListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % sendList(1))
- nullify(dataFieldPtr % sendList(1) % next)
- dataFieldPtr % sendList(1) % next => exchFieldPtr % sendList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
- exchFieldPtr => recvListField
- dataFieldPtr => neededListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % recvList(1))
- allocate(dataFieldPtr % copyList(1))
- nullify(dataFieldPtr % recvList(1) % next)
- nullify(dataFieldPtr % copyList(1) % next)
- dataFieldPtr % recvList(1) % next => exchFieldPtr % recvList(1) % next
- dataFieldPtr % copyList(1) % next => exchFieldPtr % copyList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
-
- end subroutine mpas_link_exchange_list_field3d_integer!}}}
-
- subroutine mpas_link_exchange_list_field1d_real(sendListField, recvListField, ownedListField, neededListField)!{{{
- type (field1dInteger), pointer :: sendListField
- type (field1dInteger), pointer :: recvListField
- type (field1dReal), pointer :: ownedListField
- type (field1dReal), pointer :: neededListField
-
- type (field1dInteger), pointer :: exchFieldPtr
- type (field1dReal), pointer :: dataFieldPtr
-
- exchFieldPtr => sendListField
- dataFieldPtr => ownedListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % sendList(1))
- nullify(dataFieldPtr % sendList(1) % next)
- dataFieldPtr % sendList(1) % next => exchFieldPtr % sendList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
- exchFieldPtr => recvListField
- dataFieldPtr => neededListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % recvList(1))
- allocate(dataFieldPtr % copyList(1))
- nullify(dataFieldPtr % recvList(1) % next)
- nullify(dataFieldPtr % copyList(1) % next)
- dataFieldPtr % recvList(1) % next => exchFieldPtr % recvList(1) % next
- dataFieldPtr % copyList(1) % next => exchFieldPtr % copyList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
-
- end subroutine mpas_link_exchange_list_field1d_real!}}}
-
- subroutine mpas_link_exchange_list_field2d_real(sendListField, recvListField, ownedListField, neededListField)!{{{
- type (field1dInteger), pointer :: sendListField
- type (field1dInteger), pointer :: recvListField
- type (field2dReal), pointer :: ownedListField
- type (field2dReal), pointer :: neededListField
-
- type (field1dInteger), pointer :: exchFieldPtr
- type (field2dReal), pointer :: dataFieldPtr
-
- exchFieldPtr => sendListField
- dataFieldPtr => ownedListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % sendList(1))
- nullify(dataFieldPtr % sendList(1) % next)
- dataFieldPtr % sendList(1) % next => exchFieldPtr % sendList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
- exchFieldPtr => recvListField
- dataFieldPtr => neededListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % recvList(1))
- allocate(dataFieldPtr % copyList(1))
- nullify(dataFieldPtr % recvList(1) % next)
- nullify(dataFieldPtr % copyList(1) % next)
- dataFieldPtr % recvList(1) % next => exchFieldPtr % recvList(1) % next
- dataFieldPtr % copyList(1) % next => exchFieldPtr % copyList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
-
- end subroutine mpas_link_exchange_list_field2d_real!}}}
-
- subroutine mpas_link_exchange_list_field3d_real(sendListField, recvListField, ownedListField, neededListField)!{{{
- type (field1dInteger), pointer :: sendListField
- type (field1dInteger), pointer :: recvListField
- type (field3dReal), pointer :: ownedListField
- type (field3dReal), pointer :: neededListField
-
- type (field1dInteger), pointer :: exchFieldPtr
- type (field3dReal), pointer :: dataFieldPtr
-
- exchFieldPtr => sendListField
- dataFieldPtr => ownedListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % sendList(1))
- nullify(dataFieldPtr % sendList(1) % next)
- dataFieldPtr % sendList(1) % next => exchFieldPtr % sendList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
- exchFieldPtr => recvListField
- dataFieldPtr => neededListField
-
- do while(associated(exchFieldPtr))
- allocate(dataFieldPtr % recvList(1))
- allocate(dataFieldPtr % copyList(1))
- nullify(dataFieldPtr % recvList(1) % next)
- nullify(dataFieldPtr % copyList(1) % next)
- dataFieldPtr % recvList(1) % next => exchFieldPtr % recvList(1) % next
- dataFieldPtr % copyList(1) % next => exchFieldPtr % copyList(1) % next
-
- exchFieldPtr => exchFieldPtr % next
- dataFieldPtr => dataFieldPtr % next
- end do
-
-
- end subroutine mpas_link_exchange_list_field3d_real!}}}
-
-!***********************************************************************
-!
-! routine mpas_get_halo_cells_and_exchange_lists
-!
-!> \brief Determines cell indices for each halo layer, and builds exchange lists
-!> \author Doug Jacobsen
-!> \date 04/30/12
-!> \version SVN:$Id$
-!> \details
-!> This routine builds the field indexToCellID_nHalos, which is an array of nHalos linked lists.
-!> Each index in indexToCellID_nHalos represnts a linked list of cells in a given halo.
-!> It creates the exchange lists for cells, and places them in the block structure.
-!> In order to call this routine, there are some assumptions made.
-!> The first assumption is that the 1 index of each array is setup correctly,
-!> ie block pointers are valid, dimSizes are valid, next pointers are valid, ets
-!> The second assumption is that the arrays in each field are allocated and full with their appropriate information.
-!> These assumptions lead to the conclusion that the 0 halo has to be properly setup prior to calling this routine.
-!
-!-----------------------------------------------------------------------
-
- subroutine mpas_get_halo_cells_and_exchange_lists(dminfo, nHalos, indexToCellID_0Halo, nEdgesOnCell_0Halo, cellsOnCell_0Halo, indexToCellID_nHalos, nEdgesOnCell_nHalos, cellsOnCell_nHalos)!{{{
-
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nHalos
- type (field1dInteger), pointer :: indexToCellID_0Halo
- type (field1dInteger), pointer :: nEdgesOnCell_0Halo
- type (field2dInteger), pointer :: cellsOnCell_0Halo
-
- type (field1dInteger), dimension(:), pointer :: indexToCellID_nHalos
- type (field1dInteger), dimension(:), pointer :: nEdgesOnCell_nHalos
- type (field2dInteger), dimension(:), pointer :: cellsOnCell_nHalos
-
- type (field1dInteger), pointer :: indexToCellID_ptr, indexToCellID_Halo_ptr
- type (field1dInteger), pointer :: nEdgesOnCell_ptr, nEdgesOnCell_Halo_ptr
- type (field2dInteger), pointer :: cellsOnCell_ptr, cellsOnCell_Halo_ptr
-
- type (field0dInteger), pointer :: offSetField
- type (field0dInteger), pointer :: offSet_ptr
-
- type (block_type), pointer :: block_ptr
-
- type (exchange_list), pointer :: recvListPtr, copyListPtr
- type (graph) :: block_graph, block_graph_with_halo
-
- integer :: nCellsInBlock, nCellsInHalo, maxEdges
- integer :: indexShift, exchListOffSet
- integer :: haloStart, haloEnd
- integer :: iHalo, i, j, k
-
- maxEdges = cellsOnCell_0Halo % dimSizes(1)
- allocate(indexToCellID_nHalos(nHalos))
- allocate(nEdgesOnCell_nHalos(nHalos))
- allocate(cellsOnCell_nHalos(nHalos))
- allocate(offSetField)
-
- block_ptr => indexToCellID_0Halo % block
- offSet_ptr => offSetField
-
- do while(associated(block_ptr))
- allocate(block_ptr % parinfo)
- allocate(block_ptr % parinfo % cellsToSend(nHalos))
- allocate(block_ptr % parinfo % cellsToRecv(nHalos))
- allocate(block_ptr % parinfo % cellsToCopy(nHalos))
- offSet_ptr % block => block_ptr
- block_ptr => block_ptr % next
- if(associated(block_ptr)) then
- allocate(offSet_ptr % next)
- offSet_ptr => offSet_ptr % next
- end if
- nullify(offSet_ptr % next)
- end do
-
- do iHalo = 1, nHalos
- ! Setup block pointers for the next halo
- indexToCellID_ptr => indexToCellID_0Halo
- nEdgesOnCell_ptr => nEdgesOnCell_0Halo
- cellsOnCell_ptr => cellsOnCell_0Halo
-
- indexToCellID_Halo_ptr => indexToCellID_nHalos(iHalo)
- nEdgesOnCell_Halo_ptr => nEdgesOnCell_nHalos(iHalo)
- cellsOnCell_Halo_ptr => cellsOnCell_nHalos(iHalo)
- do while (associated(indexToCellID_ptr))
-
- indexToCellID_Halo_ptr % block => indexToCellID_ptr % block
- nEdgesOnCell_Halo_ptr % block => nEdgesOnCell_ptr % block
- cellsOnCell_Halo_ptr % block => cellsOnCell_ptr % block
-
- indexToCellID_ptr => indexToCellID_ptr % next
- nEdgesOnCell_ptr => nEdgesOnCell_ptr % next
- cellsOnCell_ptr => cellsOnCell_ptr % next
- if(associated(indexToCellID_ptr)) then
- allocate(indexToCellID_Halo_ptr % next)
- allocate(nEdgesOnCell_Halo_ptr % next)
- allocate(cellsOnCell_Halo_ptr % next)
- indexToCellID_Halo_ptr => indexToCellID_Halo_ptr % next
- nEdgesOnCell_Halo_ptr => nEdgesOnCell_Halo_ptr % next
- cellsOnCell_Halo_ptr => cellsOnCell_Halo_ptr % next
- end if
-
- nullify(indexTocellID_Halo_ptr % next)
- nullify(nEdgesOnCell_Halo_ptr % next)
- nullify(cellsOnCell_Halo_ptr % next)
- end do
-
- indexToCellID_ptr => indexToCellID_0Halo
- nEdgesOnCell_ptr => nEdgesOnCell_0Halo
- cellsOnCell_ptr => cellsOnCell_0Halo
- offSet_ptr => offSetField
- do while (associated(indexToCellID_ptr))
- nCellsInBlock = indexToCellID_ptr % dimSizes(1)
-
- ! Determine number of total cells in block and halos
- do k = 1, iHalo-1
- indexToCellID_Halo_ptr => indexToCellID_nHalos(k)
- do while(associated(indexToCellID_Halo_ptr))
- if(indexToCellID_Halo_ptr % block % blockID == indexToCellID_ptr % block % blockID) exit
- indexToCellID_Halo_ptr => indexToCellID_Halo_ptr % next
- end do
- nCellsInBlock = nCellsInBlock + indexToCellID_Halo_ptr % dimSizes(1)
- end do
-
- ! Setup block graph, using owned and halo cells
- offSet_ptr % scalar = nCellsInBlock
- block_graph % nVertices = nCellsInBlock
- block_graph % nVerticesTotal = nCellsInBlock
- block_graph % maxDegree = maxEdges
- block_graph % ghostStart = nCellsInBlock + 1
-
- allocate(block_graph % vertexID(nCellsInBlock))
- allocate(block_graph % nAdjacent(nCellsInBlock))
- allocate(block_graph % adjacencyList(maxEdges, nCellsInBlock))
-
- ! Add all owned cells to graph
- indexShift = 0
- block_graph % vertexID(indexShift+1:indexToCellID_ptr % dimSizes(1)) = indexToCellID_ptr % array(:)
- block_graph % nAdjacent(indexShift+1:nEdgesOnCell_ptr % dimSizes(1)) = nEdgesOnCell_ptr % array(:)
- block_graph % adjacencyList(:,indexShift+1:cellsOnCell_ptr % dimSizes(2)) = cellsOnCell_ptr % array(:,:)
-
- ! Add all halo cells to graph
- indexShift = indexShift + indexToCellID_ptr % dimSizes(1)
- do k = 1, iHalo-1
- indexToCellID_Halo_ptr => indexToCellID_nHalos(k)
- nEdgesOnCell_Halo_ptr => nEdgesOnCell_nHalos(k)
- cellsOnCell_Halo_ptr => cellsOnCell_nHalos(k)
- do while(associated(indexToCellID_Halo_ptr))
- if(indexToCellID_Halo_ptr % block % blockID == indexToCellID_ptr % block % blockID) exit
- indexToCellID_Halo_ptr => indexToCellID_Halo_ptr % next
- nEdgesOnCell_Halo_ptr => nEdgesOnCell_Halo_ptr % next
- cellsOnCell_Halo_ptr => cellsOnCell_Halo_ptr % next
- end do
-
- block_graph % vertexID(indexShift+1:indexShift+indexToCellID_Halo_ptr % dimSizes(1)) = indexToCellID_Halo_ptr % array(:)
- block_graph % nAdjacent(indexShift+1:indexShift+nEdgesOnCell_Halo_ptr % dimSizes(1)) = nEdgesOnCell_Halo_ptr % array(:)
- block_graph % adjacencyList(:,indexShift+1:indexShift+cellsOnCell_Halo_ptr % dimSizes(2)) = cellsOnCell_Halo_ptr % array(:,:)
- indexShift = indexShift + indexToCellID_Halo_ptr % dimSizes(1)
- end do
-
- ! Get a new block graph with the next halo layer added.
- call mpas_block_decomp_add_halo(dminfo, block_graph, block_graph_with_halo)
-
- indexToCellID_Halo_ptr => indexToCellID_nHalos(iHalo)
- nEdgesOnCell_Halo_ptr => nEdgesOnCell_nHalos(iHalo)
- cellsOnCell_Halo_ptr => cellsOnCell_nHalos(iHalo)
-
- do while(associated(indexToCellID_Halo_ptr))
-
- if(indexToCellID_Halo_ptr % block % blockID == indexToCellID_ptr % block % blockID) exit
-
- indexToCellID_Halo_ptr => indexToCellID_Halo_ptr % next
- nEdgesOnCell_Halo_ptr => nEdgesOnCell_Halo_ptr % next
- cellsOnCell_Halo_ptr => cellsOnCell_Halo_ptr % next
- end do
-
- haloStart = block_graph_with_halo % nVertices
- haloEnd = block_graph_with_halo % nVerticesTotal
- nCellsInHalo = haloEnd - haloStart
-
- indexToCellID_Halo_ptr % dimSizes(1) = nCellsInHalo
- nEdgesOnCell_Halo_ptr % dimSizes(1) = nCellsInHalo
- cellsOnCell_Halo_ptr % dimSizes(1) = maxEdges
- cellsOnCell_Halo_ptr % dimSizes(2) = nCellsInHalo
-
- allocate(indexToCellID_Halo_ptr % array(nCellsInHalo))
- allocate(nEdgesOnCell_Halo_ptr % array(nCellsInHalo))
- allocate(cellsOnCell_Halo_ptr % array(maxEdges, nCellsInHalo))
-
- indexToCellID_Halo_ptr % array(:) = block_graph_with_halo % vertexID(haloStart+1:haloEnd)
-
- deallocate(block_graph % vertexID)
- deallocate(block_graph % nAdjacent)
- deallocate(block_graph % adjacencyList)
- deallocate(block_graph_with_halo % vertexID)
- deallocate(block_graph_with_halo % nAdjacent)
- deallocate(block_graph_with_halo % adjacencyList)
- indexToCellID_ptr => indexToCellID_ptr % next
- nEdgesOnCell_ptr => nEdgesOnCell_ptr % next
- cellsOnCell_ptr => cellsOnCell_ptr % next
- offSet_ptr => offSet_ptr % next
- end do
-
- indexToCellID_Halo_ptr => indexToCellID_nHalos(iHalo)
- nEdgesOnCell_Halo_ptr => nEdgesOnCell_nHalos(iHalo)
- cellsOnCell_Halo_ptr => cellsOnCell_nHalos(iHalo)
-
- call mpas_get_exchange_lists(dminfo, indexToCellID_0Halo, .true., indexToCellID_Halo_ptr, .true.)
-
- call mpas_link_exchange_list_field(indexToCellID_0Halo, indexToCellID_Halo_ptr, nEdgesOnCell_0Halo, nEdgesOnCell_Halo_ptr)
- call mpas_link_exchange_list_field(indexToCellID_0Halo, indexToCellID_Halo_ptr, cellsOnCell_0Halo, cellsOnCell_Halo_ptr)
-
- call mpas_dmpar_alltoall_field(dminfo, indexToCellID_0Halo, indexToCellID_Halo_ptr)
- call mpas_dmpar_alltoall_field(dminfo, nEdgesOnCell_0Halo, nEdgesOnCell_Halo_ptr)
- call mpas_dmpar_alltoall_field(dminfo, cellsOnCell_0Halo, cellsOnCell_Halo_ptr)
-
- indexToCellID_ptr => indexToCellID_0Halo
- indexToCellID_Halo_ptr => indextoCellID_nHalos(iHalo)
- offSet_ptr => offSetField
- do while(associated(indexToCellID_ptr))
- indexToCellID_ptr % block % parinfo % cellsToSend(iHalo) = indexToCellID_ptr % sendList(1)
- indexToCellID_ptr % block % parinfo % cellsToRecv(iHalo) = indexToCellID_Halo_ptr % recvList(1)
- indexToCellID_ptr % block % parinfo % cellsToCopy(iHalo) = indexToCellID_Halo_ptr % copyList(1)
-
- recvListPtr => indexToCellID_ptr % block % parinfo % cellsToRecv(iHalo) % next
- do while(associated(recvListPtr))
- recvListPtr % list = recvListPtr % list + offSet_ptr % scalar
- recvListPtr => recvListPtr % next
- end do
-
- copyListPtr => indexToCellID_ptr % block % parinfo % cellsToCopy(iHalo) % next
- do while(associated(copyListPtr))
- copyListPtr % list = copyListPtr % list + offSet_ptr % scalar
- copyListPtr => copyListPtr % next
- end do
-
- deallocate(indexToCellID_ptr % sendList)
- deallocate(indexToCellID_Halo_ptr % recvList)
- deallocate(indexToCellID_Halo_ptr % copyList)
-
- indexToCellID_ptr => indexToCellID_ptr % next
- indextoCellID_Halo_ptr => indexToCellID_Halo_ptr % next
- offSet_ptr => offSet_ptr % next
- end do
-
- end do ! iHalo loop over nHalos
-
- end subroutine mpas_get_halo_cells_and_exchange_lists !}}}
-
-!***********************************************************************
-!
-! routine mpas_get_vertex_ids_and_exchange_lists
-!
-!> \brief Determines vertex indices for each halo layer, and builds exchange lists
-!> \author Doug Jacobsen
-!> \date 05/01/12
-!> \version SVN:$Id$
-!> \details
-!> This routine fills in the arrays for the indexToVertexID_0Halo, and indexToVertexID_nHalos
-!> indexToVertexID_0Halo represents all vertices in the 0 halo, while indexToVertexID_nHalos represnts
-!> the vertex id's for all vertices in all other halos. It is an array of linked lists where each
-!> index represents the linked list of vertex ids at that halo layer.
-!> It creates the exchange lists for vertices, and places them in the block structure.
-!> In order to call this routine, there are some assumptions made.
-!> The first assumption is that the 1 index of each array is setup correctly,
-!> ie block pointers are valid, dimSizes are valid, next pointers are valid, ets
-!> The second assumption is that the arrays in each field are allocated and full with their appropriate information.
-!> These assumptions lead to the conclusion that the 0 halo has to be properly setup prior to calling this routine.
-!
-!-----------------------------------------------------------------------
-
- subroutine mpas_get_vertex_ids_and_exchange_lists(dminfo, nHalos, maxEdges, vertexDegree, indexToCellID_0Halo, nEdgesOnCell_0Halo, verticesOnCell_0Halo, cellsOnVertex_0Halo, indexToCellID_nHalos, indexToVertexID_0Halo, indexToVertexID_nHalos)!{{{
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: nHalos
- integer, intent(in) :: maxEdges
- integer, intent(in) :: vertexDegree
-
- type(field1dInteger), pointer :: indexToCellID_0Halo
- type(field1dInteger), pointer :: nEdgesOnCell_0Halo
- type(field1dInteger), pointer :: verticesOnCell_0Halo
- type(field1dInteger), pointer :: cellsOnVertex_0Halo
- type(field1dInteger), dimension(:), pointer :: indexToCellID_nHalos
-
- type(field1dInteger), pointer :: indexToVertexID_0Halo
- type(field1dInteger), dimension(:), pointer :: indexToVertexID_nHalos
-
- type(field1dInteger), dimension(:), pointer :: cellsOnVertex_nHalos
- type(field1dInteger), dimension(:), pointer :: nEdgesOnCell_nHalos
-
- type(field1dInteger), pointer :: indexToCellID_ptr, nEdgesOnCell_ptr, verticesOnCell_ptr, cellsOnVertex_ptr, indexToVertexID_ptr
- type(field1dInteger), pointer :: indexToCellID_Halo_ptr, indexToVertexID_Halo_ptr
-
- integer, dimension(:), pointer :: all_vertices_in_block
- integer :: nCellsInBlock
- integer :: nVerticesInBlock
- integer :: nVerticesInHalo, haloStart, haloEnd
-
- type (graph) :: block_graph, block_graph_with_halo
-
- integer :: iCell, iVertex
- integer :: i, j, k, iHalo
-
- allocate(indexToVertexID_0Halo)
- allocate(indexToVertexID_nHalos(nHalos+1)) ! 1 more halo than cells
- allocate(cellsOnVertex_nHalos(nHalos+1)) ! 1 more halo than cells
- allocate(nEdgesOnCell_nHalos(nHalos))
-
- ! Build the 0 and 1 halos
- indexToCellID_ptr => indexToCellID_0Halo
- nEdgesOnCell_ptr => nEdgesOnCell_0Halo
- verticesOnCell_ptr => verticesOnCell_0Halo
- cellsOnVertex_ptr => cellsOnVertex_0Halo
- indexToVertexID_ptr => indexToVertexID_0Halo
- indexToVertexID_Halo_ptr => indexToVertexID_nHalos(1)
- do while(associated(indexToCellID_ptr))
- nCellsInBlock = indexToCellID_ptr % dimSizes(1)
-
- call mpas_block_decomp_all_edges_in_block(maxEdges, nCellsInBlock, nEdgesOnCell_ptr % array, verticesOnCell_ptr % array, nVerticesInBlock, all_vertices_in_block)
- call mpas_block_decomp_partitioned_edge_list(nCellsInBlock, indexToCellID_ptr % array, vertexDegree, nVerticesInBlock, cellsOnVertex_ptr % array, all_vertices_in_block, haloStart)
-
-! call mpas_block_decomp_all_edges_in_block(maxEdges, block_graph_2Halo % nVerticesTotal, block_graph_2Halo % nAdjacent, &
-! verticesOnCell_2Halo, nlocal_vertices, local_vertex_list)
-
-! call mpas_block_decomp_partitioned_edge_list(nOwnCells, &
-! block_graph_2Halo % vertexID(1:nOwnCells), &
-! vertexDegree, nlocal_vertices, cellsOnVertex_2Halo, local_vertex_list, ghostVertexStart)
-
- indexToVertexID_ptr % block => indexToCellID_ptr % block
- indexToVertexID_ptr % dimSizes(1) = haloStart
- allocate(indexToVertexID_ptr % array(indexToVertexID_ptr % dimSizes(1)))
-
- indexToVertexID_ptr % array(:) = all_vertices_in_block(1:haloStart)
-
- indexToVertexID_Halo_ptr % block => indexToCellID_Halo_ptr % block
- indexToVertexID_Halo_ptr % dimSizes(1) = nVerticesInBlock - haloStart
- allocate(indexToVertexID_Halo_ptr % array(indexToVertexID_Halo_ptr % dimSizes(1)))
-
- indexToVertexID_Halo_ptr % array(:) = all_vertices_in_block(haloStart+1:nVerticesInBlock)
-
- indexToCellID_ptr => indexToCellID_ptr % next
- verticesOnCell_ptr => verticesOnCell_ptr % next
- cellsOnVertex_ptr => cellsOnVertex_ptr % next
- if(associated(indexToCellID_ptr)) then
- allocate(indexToVertexID_ptr % next)
- indexToVertexID_ptr => indexToVertexID_ptr % next
- end if
-
- nullify(indexToVertexID_ptr % next)
- end do
-
- end subroutine mpas_get_vertex_ids_and_exchange_lists!}}}
-
-
end module mpas_block_decomp
Modified: branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar.F
===================================================================
--- branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar.F 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar.F 2012-05-22 20:50:11 UTC (rev 1930)
@@ -595,8 +595,6 @@
! 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
@@ -713,9 +711,10 @@
allocate(ownerListIn(totalSize))
allocate(ownerListOut(totalSize))
+ nMesgSend = nNeededList
+! ownerListOut(1:nNeededList) = neededList(1:nNeededList)
nMesgRecv = nNeededList
- nMesgSend = nMesgRecv
- ownerListIn(1:nNeededList) = neededList(1:nNeededList)
+ ownerListOut(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)
@@ -723,7 +722,6 @@
allocate(numToSend(nOwnedBlocks))
allocate(numToRecv(nNeededBlocks))
- 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)
@@ -739,7 +737,6 @@
! 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
@@ -750,11 +747,13 @@
if (ownerListIn(j) > 0) then
k = mpas_binary_search(ownedListSorted, 2, 1, nOwnedList, ownerListIn(j))
if (k <= nOwnedList) then
+ iBlock = ownedBlockSorted(2,k) + 1
ownerListOut(j) = -1 * dminfo % my_proc_id
- numToSend(ownedBlockSorted(2,k)) = numToSend(ownedBlockSorted(2,k)) + 1
+ numToSend(iBlock) = numToSend(iBlock) + 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(1,ownedListSorted(2,k)) = numToSend(iBlock)
! recipientList(2,:) represnets the index in the buffer to place this data
recipientList(2,ownedListSorted(2,k)) = totalSent
else
@@ -769,27 +768,33 @@
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
+ ! Find end of send list
+ if(.not.associated(fieldCursor % sendList % halos(haloLayer) % exchList)) then
+ allocate(fieldCursor % sendList % halos(haloLayer) % exchList)
+ exchListPtr => fieldCursor % sendList % halos(haloLayer) % exchList
+ nullify(exchListPtr % next)
+ else
+ exchListPtr => fieldCursor % sendList % halos(haloLayer) % exchList
+ exchListPtr2 => fieldCursor % sendList % halos(haloLayer) % exchList % next
+ do while(associated(exchListPtr2))
+ exchListPtr => exchListPtr % next
+ exchListPtr2 => exchListPtr % next
+ end do
- if (numToSend(iBlock) > 0) then
- allocate(exchListPtr % next)
- exchListPtr => exchListPtr % next
+ allocate(exchListPtr % next)
+ exchListPtr => exchListPtr % next
+ nullify(exchListPtr % next)
+ end if
+
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(1,j) /= -1) then
- if(ownedBlock(j) == fieldCursor % block % blockID) then
+ if(ownedBlock(j) == fieldCursor % block % localBlockID) then
exchListPtr % srcList(recipientList(1,j)) = ownedListIndex(j)
exchListPtr % destList(recipientList(1,j)) = recipientList(2,j)
kk = kk + 1
@@ -818,49 +823,57 @@
! 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
+ if(i == dminfo % my_proc_id) cycle
- fieldCursor => neededListField
- totalRecv = 0
- do while (associated(fieldCursor))
- iBlock = fieldCursor % block % localBlockID + 1
+ numToRecv(:) = 0
+ do j=1,nNeededList
+ iBlock = neededBlock(j) + 1
+ if (ownerListIn(j) == -i) numToRecv(iBlock) = numToRecv(iBlock) + 1
+ end do
- ! 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
+ fieldCursor => neededListField
+ totalRecv = 0
+ do while (associated(fieldCursor))
+ iBlock = fieldCursor % block % localBlockID + 1
- if (numToRecv(iBlock) > 0) then
+ if (numToRecv(iBlock) > 0) then
+ if(.not.associated(fieldCursor % recvList % halos(haloLayer) % exchList)) then
+ allocate(fieldCursor % recvList % halos(haloLayer) % exchList)
+ exchListPtr => fieldCursor % recvList % halos(haloLayer) % exchList
+ nullify(exchListPtr % next)
+ else
+ ! Find end of recv list
+ exchListPtr => fieldCursor % recvList % halos(haloLayer) % exchList
+ exchListPtr2 => fieldCursor % recvList % halos(haloLayer) % exchList % next
+ do while(associated(exchListPtr2))
+ exchListPtr => exchListPtr % next
+ exchListPtr2 => exchListPtr % next
+ end do
+
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
+ exchListPtr % endPointID = i
+ exchListPtr % nlist = numToRecv(iBlock)
+ allocate(exchListPtr % srcList(numToRecv(iBlock)))
+ allocate(exchListPtr % destList(numToRecv(iBlock)))
+ kk = 1
+ do j=1,nNeededList
+ if (ownerListIn(j) == -i) then
+ if (neededBlock(j) == fieldCursor % block % localBlockID) 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 do
!
@@ -913,24 +926,31 @@
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))
+ if(.not.associated(fieldCursor % copyList % halos(haloLayer) % exchList)) then
+ allocate(fieldCursor % copyList % halos(haloLayer) % exchList)
+ exchListPtr => fieldCursor % copyList % halos(haloLayer) % exchList
+ nullify(exchListPtr % next)
+ else
+ ! Find end of copy list
+ exchListPtr => fieldCursor % copyList % halos(haloLayer) % exchList
+ exchListPtr2 => fieldCursor % copyList % halos(haloLayer) % exchList % next
+ do while(associated(exchListPtr2))
+ exchListPtr => exchListPtr % next
+ exchListPtr2 => exchListPtr % next
+ end do
+
+ allocate(exchListPtr % next)
exchListPtr => exchListPtr % next
- exchListPtr2 => exchListPtr2 % next
- end do
+ nullify(exchListPtr % next)
+ end if
- 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
+ if(recipientList(1,j) == fieldCursor2 % block % localBlockID) then
exchListPtr % srcList(kk) = j
exchListPtr % destList(kk) = recipientList(2,j)
kk = kk + 1
@@ -946,32 +966,6 @@
end do
deallocate(numToSend)
- !
- ! 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
-
- fieldCursor => neededListField
- do while(associated(fieldCursor))
- exchListPtr => fieldCursor % recvList(haloLayer)
- fieldCursor % recvList(haloLayer) = fieldCursor % recvList(haloLayer) % next
- deallocate(exchListPtr)
-
- 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)!{{{
@@ -992,7 +986,7 @@
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: iHalo, i
+ integer :: iHalo, iBuffer, i
integer :: nHaloLayers
integer, dimension(:), pointer :: haloLayers
@@ -1005,7 +999,7 @@
haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(fieldIn % sendList)
+ nHaloLayers = size(fieldIn % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
haloLayers(iHalo) = iHalo
@@ -1013,17 +1007,14 @@
end if
#ifdef _MPI
- allocate(sendList)
- nullify(sendList % next)
+ nullify(sendList)
+ nullify(recvList)
- allocate(recvList)
- nullify(recvList % 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))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1041,19 +1032,27 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => recvList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- commListPtr2 => commListPtr % next
- end do
+ nullify(commListPtr % next)
+ end if
- allocate(commListPtr % next)
- commListPtr => commListPtr % next
commListPtr % procID = exchListPtr % endPointID
commListPtr % nList = exchListPtr % nList
end if
-
+
exchListPtr => exchListPtr % next
end do
@@ -1066,14 +1065,14 @@
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
+ 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(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1091,15 +1090,22 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => sendList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- commListPtr2 => commListPtr % next
- end do
-
- allocate(commListPtr % next)
- commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
commListPtr % procID = exchListPtr % endPointID
commListPtr % nList = exchListPtr % nList
end if
@@ -1120,11 +1126,12 @@
nAdded = 0
fieldInPtr => fieldIn
do while(associated(fieldInPtr))
- exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
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))
+ iBuffer = exchListPtr % destList(i) + bufferOffset
+ commListPtr % ibuffer(iBuffer) = fieldInPtr % array(exchListPtr % srcList(i))
nAdded = nAdded + 1
end do
end if
@@ -1142,13 +1149,14 @@
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))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
@@ -1162,6 +1170,7 @@
exchListPtr => exchListPtr % next
end do
+ fieldInPtr => fieldInPtr % next
end do
end do
@@ -1176,11 +1185,12 @@
nAdded = 0
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
- exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
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)
+ iBuffer = exchListPtr % srcList(i) + bufferOffset
+ fieldOutPtr % array(exchListPtr % destList(i)) = commListPtr % ibuffer(iBuffer)
nAdded = nAdded + 1
end do
end if
@@ -1207,6 +1217,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_alltoall_field1d_integer!}}}
subroutine mpas_dmpar_alltoall_field2d_integer(fieldIn, fieldout, haloLayersIn)!{{{
@@ -1227,38 +1239,35 @@
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: iHalo, i, j
+ integer :: iHalo, iBuffer, 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)
+ haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(fieldIn % sendList)
+ nHaloLayers = size(fieldIn % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
- haloLayers(iHalo) = i
+ haloLayers(iHalo) = iHalo
end do
end if
#ifdef _MPI
- allocate(sendList)
- nullify(sendList % next)
+ nullify(sendList)
+ nullify(recvList)
- allocate(recvList)
- nullify(recvList % 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))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1266,7 +1275,7 @@
commListPtr => recvList
do while(associated(commListPtr))
if(commListPtr % procID == exchListPtr % endPointID) then
- commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1)
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1)
comm_list_found = .true.
exit
end if
@@ -1276,19 +1285,28 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => recvList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ if(.not.associated(recvList)) then
+ allocate(recvList)
+ nullify(recvList % next)
+ commListPtr => recvList
+ else
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ write(6,*) 'create loop'
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
commListPtr => commListPtr % next
- commListPtr2 => commListPtr % next
- end do
+ nullify(commListPtr % next)
+ end if
- allocate(commListPtr % next)
- commListPtr => commListPtr % next
commListPtr % procID = exchListPtr % endPointID
commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1)
end if
-
+
exchListPtr => exchListPtr % next
end do
@@ -1301,14 +1319,14 @@
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
+ 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(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1326,15 +1344,22 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => sendList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- 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)
end if
@@ -1355,12 +1380,13 @@
nAdded = 0
fieldInPtr => fieldIn
do while(associated(fieldInPtr))
- exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ 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(1)
- commListPtr % ibuffer((exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) + j + bufferOffset) = fieldInPtr % array(j, exchListPtr % srcList(i))
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) + j + bufferOffset
+ commListPtr % ibuffer(iBuffer) = fieldInPtr % array(j, exchListPtr % srcList(i))
nAdded = nAdded + 1
end do
end do
@@ -1385,7 +1411,7 @@
do iHalo = 1, nHaloLayers
fieldInPtr => fieldIn
do while(associated(fieldInPtr))
- exchListPtr => fieldInPtr % copyList(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
@@ -1399,6 +1425,7 @@
exchListPtr => exchListPtr % next
end do
+ fieldInPtr => fieldInPtr % next
end do
end do
@@ -1413,12 +1440,13 @@
nAdded = 0
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
- exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ 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(1)
- fieldOutPtr % array(j, exchListPtr % destList(i)) = commListPtr % ibuffer((exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(1) + j + bufferOffset)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(1) + j + bufferOffset
+ fieldOutPtr % array(j, exchListPtr % destList(i)) = commListPtr % ibuffer(iBuffer)
nAdded = nAdded + 1
end do
end do
@@ -1446,6 +1474,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_alltoall_field2d_integer!}}}
subroutine mpas_dmpar_alltoall_field3d_integer(fieldIn, fieldout, haloLayersIn)!{{{
@@ -1466,38 +1496,35 @@
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: iHalo, i, j, k
+ integer :: iHalo, iBuffer, 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)
+ haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(fieldIn % sendList)
+ nHaloLayers = size(fieldIn % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
- haloLayers(iHalo) = i
+ haloLayers(iHalo) = iHalo
end do
end if
#ifdef _MPI
- allocate(sendList)
- nullify(sendList % next)
+ nullify(sendList)
+ nullify(recvList)
- allocate(recvList)
- nullify(recvList % 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))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1505,7 +1532,7 @@
commListPtr => recvList
do while(associated(commListPtr))
if(commListPtr % procID == exchListPtr % endPointID) then
- commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
comm_list_found = .true.
exit
end if
@@ -1515,19 +1542,27 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => recvList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- commListPtr2 => commListPtr % next
- end do
+ nullify(commListPtr % next)
+ end if
- 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
@@ -1540,14 +1575,14 @@
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
+ 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(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1565,15 +1600,22 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => sendList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- 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)
end if
@@ -1594,14 +1636,14 @@
nAdded = 0
fieldInPtr => fieldIn
do while(associated(fieldInPtr))
- exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ 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(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))
+ do j = 1, fieldInPtr % dimSizes(2)
+ do k = 1, fieldInPtr % dimSizes(1)
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) + (j-1) * fieldInPtr % dimSizes(1) + k + bufferOffset
+ commListPtr % ibuffer(iBuffer) = fieldInPtr % array(k, j, exchListPtr % srcList(i))
nAdded = nAdded + 1
end do
end do
@@ -1621,13 +1663,14 @@
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))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
@@ -1641,6 +1684,7 @@
exchListPtr => exchListPtr % next
end do
+ fieldInPtr => fieldInPtr % next
end do
end do
@@ -1655,14 +1699,14 @@
nAdded = 0
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
- exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ 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(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)
+ do j = 1, fieldOutPtr % dimSizes(2)
+ do k = 1, fieldOutPtr % dimSizes(1)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(1) + (j-1) * fieldOutPtr % dimSizes(1) + k + bufferOffset
+ fieldOutPtr % array(k, j, exchListPtr % destList(i)) = commListPtr % ibuffer(iBuffer)
nAdded = nAdded + 1
end do
end do
@@ -1691,6 +1735,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_alltoall_field3d_integer!}}}
subroutine mpas_dmpar_alltoall_field1d_real(fieldIn, fieldout, haloLayersIn)!{{{
@@ -1711,38 +1757,35 @@
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: iHalo, i
+ integer :: iHalo, iBuffer, 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)
+ haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(fieldIn % sendList)
+ nHaloLayers = size(fieldIn % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
- haloLayers(iHalo) = i
+ haloLayers(iHalo) = iHalo
end do
end if
#ifdef _MPI
- allocate(sendList)
- nullify(sendList % next)
+ nullify(sendList)
+ nullify(recvList)
- allocate(recvList)
- nullify(recvList % 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))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1760,19 +1803,27 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => recvList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- commListPtr2 => commListPtr % next
- end do
+ nullify(commListPtr % next)
+ end if
- allocate(commListPtr % next)
- commListPtr => commListPtr % next
commListPtr % procID = exchListPtr % endPointID
commListPtr % nList = exchListPtr % nList
end if
-
+
exchListPtr => exchListPtr % next
end do
@@ -1784,15 +1835,15 @@
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
+ 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(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1810,15 +1861,22 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => sendList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- commListPtr2 => commListPtr % next
- end do
-
- allocate(commListPtr % next)
- commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
commListPtr % procID = exchListPtr % endPointID
commListPtr % nList = exchListPtr % nList
end if
@@ -1839,11 +1897,12 @@
nAdded = 0
fieldInPtr => fieldIn
do while(associated(fieldInPtr))
- exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
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))
+ iBuffer = exchListPtr % destList(i) + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(exchListPtr % srcList(i))
nAdded = nAdded + 1
end do
end if
@@ -1856,18 +1915,19 @@
bufferOffset = bufferOffset + nAdded
end do
- call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_REALKIND, &
+ 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))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
@@ -1881,6 +1941,7 @@
exchListPtr => exchListPtr % next
end do
+ fieldInPtr => fieldInPtr % next
end do
end do
@@ -1895,11 +1956,12 @@
nAdded = 0
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
- exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
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)
+ iBuffer = exchListPtr % srcList(i) + bufferOffset
+ fieldOutPtr % array(exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
nAdded = nAdded + 1
end do
end if
@@ -1926,6 +1988,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_alltoall_field1d_real!}}}
subroutine mpas_dmpar_alltoall_field2d_real(fieldIn, fieldout, haloLayersIn)!{{{
@@ -1946,38 +2010,35 @@
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: iHalo, i, j
+ integer :: iHalo, iBuffer, 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)
+ haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(fieldIn % sendList)
+ nHaloLayers = size(fieldIn % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
- haloLayers(iHalo) = i
+ haloLayers(iHalo) = iHalo
end do
end if
#ifdef _MPI
- allocate(sendList)
- nullify(sendList % next)
+ nullify(sendList)
+ nullify(recvList)
- allocate(recvList)
- nullify(recvList % 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))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -1985,7 +2046,7 @@
commListPtr => recvList
do while(associated(commListPtr))
if(commListPtr % procID == exchListPtr % endPointID) then
- commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1)
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1)
comm_list_found = .true.
exit
end if
@@ -1995,19 +2056,27 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => recvList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- commListPtr2 => commListPtr % next
- end do
+ nullify(commListPtr % next)
+ end if
- allocate(commListPtr % next)
- commListPtr => commListPtr % next
commListPtr % procID = exchListPtr % endPointID
commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1)
end if
-
+
exchListPtr => exchListPtr % next
end do
@@ -2019,15 +2088,15 @@
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
+ 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(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -2045,15 +2114,22 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => sendList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- 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)
end if
@@ -2074,12 +2150,13 @@
nAdded = 0
fieldInPtr => fieldIn
do while(associated(fieldInPtr))
- exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ 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(1)
- commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) + j + bufferOffset) = fieldInPtr % array(j, exchListPtr % srcList(i))
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) + j + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(j, exchListPtr % srcList(i))
nAdded = nAdded + 1
end do
end do
@@ -2093,18 +2170,19 @@
bufferOffset = bufferOffset + nAdded
end do
- call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_REALKIND, &
+ 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))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
@@ -2118,6 +2196,7 @@
exchListPtr => exchListPtr % next
end do
+ fieldInPtr => fieldInPtr % next
end do
end do
@@ -2132,12 +2211,13 @@
nAdded = 0
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
- exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ 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(1)
- fieldOutPtr % array(j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(1) + j + bufferOffset)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(1) + j + bufferOffset
+ fieldOutPtr % array(j, exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
nAdded = nAdded + 1
end do
end do
@@ -2165,6 +2245,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_alltoall_field2d_real!}}}
subroutine mpas_dmpar_alltoall_field3d_real(fieldIn, fieldout, haloLayersIn)!{{{
@@ -2185,38 +2267,35 @@
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: nAdded, bufferOffset
integer :: mpi_ierr
- integer :: iHalo, i, j, k
+ integer :: iHalo, iBuffer, 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)
+ haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(fieldIn % sendList)
+ nHaloLayers = size(fieldIn % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
- haloLayers(iHalo) = i
+ haloLayers(iHalo) = iHalo
end do
end if
#ifdef _MPI
- allocate(sendList)
- nullify(sendList % next)
+ nullify(sendList)
+ nullify(recvList)
- allocate(recvList)
- nullify(recvList % 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))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -2224,7 +2303,7 @@
commListPtr => recvList
do while(associated(commListPtr))
if(commListPtr % procID == exchListPtr % endPointID) then
- commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2)
comm_list_found = .true.
exit
end if
@@ -2234,19 +2313,27 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => recvList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- commListPtr2 => commListPtr % next
- end do
+ nullify(commListPtr % next)
+ end if
- 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
@@ -2258,15 +2345,15 @@
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
+ 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(haloLayers(iHalo))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -2284,15 +2371,22 @@
! If no comm list exists, create a new one.
if(.not. comm_list_found) then
- commListPtr => sendList
- commListPtr2 => commListPtr % next
- do while(associated(commListPtr2))
+ 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
- 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)
end if
@@ -2313,14 +2407,14 @@
nAdded = 0
fieldInPtr => fieldIn
do while(associated(fieldInPtr))
- exchListPtr => fieldInPtr % sendList(haloLayers(iHalo))
+ 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(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))
+ do j = 1, fieldInPtr % dimSizes(2)
+ do k = 1, fieldInPtr % dimSizes(1)
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) + (j-1) * fieldInPtr % dimSizes(1) + k + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(k, j, exchListPtr % srcList(i))
nAdded = nAdded + 1
end do
end do
@@ -2335,18 +2429,19 @@
bufferOffset = bufferOffset + nAdded
end do
- call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_REALKIND, &
+ 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))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
@@ -2360,6 +2455,7 @@
exchListPtr => exchListPtr % next
end do
+ fieldInPtr => fieldInPtr % next
end do
end do
@@ -2374,14 +2470,14 @@
nAdded = 0
fieldOutPtr => fieldOut
do while(associated(fieldOutPtr))
- exchListPtr => fieldOutPtr % recvList(haloLayers(iHalo))
+ 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(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)
+ do j = 1, fieldOutPtr % dimSizes(2)
+ do k = 1, fieldOutPtr % dimSizes(1)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(1) + (j-1) * fieldOutPtr % dimSizes(1) + k + bufferOffset
+ fieldOutPtr % array(k, j, exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
nAdded = nAdded + 1
end do
end do
@@ -2410,8 +2506,11 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_alltoall_field3d_real!}}}
+
subroutine mpas_dmpar_exch_halo_field1d_integer(field, haloLayersIn)!{{{
implicit none
@@ -2439,7 +2538,7 @@
haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(field % sendList)
+ nHaloLayers = size(field % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
haloLayers(iHalo) = iHalo
@@ -2447,13 +2546,16 @@
end if
#ifdef _MPI
+ ! Allocate communication lists, and setup dead header node.
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
@@ -2465,7 +2567,7 @@
do iHalo = 1, nHaloLayers
! Determine size from send lists
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -2499,7 +2601,7 @@
end do
! Determine size from recv lists
- exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -2563,7 +2665,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -2589,7 +2691,7 @@
fieldCursor => field
do while(associated(field))
do iHalo = 1, nHaloLayers
- exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldCursor2 => field
@@ -2621,7 +2723,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % recvList(iHalo)
+ exchListPtr => fieldCursor % recvList % halos(iHalo) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -2651,6 +2753,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_exch_halo_field1d_integer!}}}
subroutine mpas_dmpar_exch_halo_field2d_integer(field, haloLayersIn)!{{{
@@ -2680,7 +2784,7 @@
haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(field % sendList)
+ nHaloLayers = size(field % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
haloLayers(iHalo) = iHalo
@@ -2688,13 +2792,16 @@
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
@@ -2706,7 +2813,7 @@
do iHalo = 1, nHaloLayers
! Determine size from send lists
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -2740,7 +2847,7 @@
end do
! Determine size from recv lists
- exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -2804,7 +2911,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -2832,7 +2939,7 @@
fieldCursor => field
do while(associated(field))
do iHalo = 1, nHaloLayers
- exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldCursor2 => field
@@ -2864,7 +2971,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % recvList(iHalo)
+ exchListPtr => fieldCursor % recvList % halos(iHalo) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -2896,6 +3003,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_exch_halo_field2d_integer!}}}
subroutine mpas_dmpar_exch_halo_field3d_integer(field, haloLayersIn)!{{{
@@ -2925,7 +3034,7 @@
haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(field % sendList)
+ nHaloLayers = size(field % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
haloLayers(iHalo) = iHalo
@@ -2933,13 +3042,16 @@
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
@@ -2951,7 +3063,7 @@
do iHalo = 1, nHaloLayers
! Determine size from send lists
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -2985,7 +3097,7 @@
end do
! Determine size from recv lists
- exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -3049,7 +3161,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -3080,7 +3192,7 @@
fieldCursor => field
do while(associated(field))
do iHalo = 1, nHaloLayers
- exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldCursor2 => field
@@ -3112,7 +3224,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % recvList(iHalo)
+ exchListPtr => fieldCursor % recvList % halos(iHalo) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -3147,6 +3259,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_exch_halo_field3d_integer!}}}
subroutine mpas_dmpar_exch_halo_field1d_real(field, haloLayersIn)!{{{
@@ -3176,7 +3290,7 @@
haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(field % sendList)
+ nHaloLayers = size(field % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
haloLayers(iHalo) = iHalo
@@ -3184,13 +3298,16 @@
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
@@ -3202,7 +3319,7 @@
do iHalo = 1, nHaloLayers
! Determine size from send lists
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -3236,7 +3353,7 @@
end do
! Determine size from recv lists
- exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -3300,7 +3417,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -3326,7 +3443,7 @@
fieldCursor => field
do while(associated(field))
do iHalo = 1, nHaloLayers
- exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldCursor2 => field
@@ -3358,7 +3475,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % recvList(iHalo)
+ exchListPtr => fieldCursor % recvList % halos(iHalo) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -3388,6 +3505,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_exch_halo_field1d_real!}}}
subroutine mpas_dmpar_exch_halo_field2d_real(field, haloLayersIn)!{{{
@@ -3417,7 +3536,7 @@
haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(field % sendList)
+ nHaloLayers = size(field % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
haloLayers(iHalo) = iHalo
@@ -3425,13 +3544,16 @@
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
@@ -3443,7 +3565,7 @@
do iHalo = 1, nHaloLayers
! Determine size from send lists
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -3477,7 +3599,7 @@
end do
! Determine size from recv lists
- exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -3541,7 +3663,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -3569,7 +3691,7 @@
fieldCursor => field
do while(associated(field))
do iHalo = 1, nHaloLayers
- exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldCursor2 => field
@@ -3601,7 +3723,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % recvList(iHalo)
+ exchListPtr => fieldCursor % recvList % halos(iHalo) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -3633,6 +3755,8 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_exch_halo_field2d_real!}}}
subroutine mpas_dmpar_exch_halo_field3d_real(field, haloLayersIn)!{{{
@@ -3662,7 +3786,7 @@
haloLayers(iHalo) = haloLayersIn(iHalo)
end do
else
- nHaloLayers = size(field % sendList)
+ nHaloLayers = size(field % sendList % halos)
allocate(haloLayers(nHaloLayers))
do iHalo = 1, nHaloLayers
haloLayers(iHalo) = iHalo
@@ -3670,13 +3794,16 @@
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
@@ -3688,7 +3815,7 @@
do iHalo = 1, nHaloLayers
! Determine size from send lists
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -3722,7 +3849,7 @@
end do
! Determine size from recv lists
- exchListPtr => fieldCursor % recvList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
comm_list_found = .false.
@@ -3786,7 +3913,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % sendList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -3817,7 +3944,7 @@
fieldCursor => field
do while(associated(field))
do iHalo = 1, nHaloLayers
- exchListPtr => fieldCursor % copyList(haloLayers(iHalo))
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
do while(associated(exchListPtr))
fieldCursor2 => field
@@ -3849,7 +3976,7 @@
nAdded = 0
fieldCursor => field
do while(associated(fieldCursor))
- exchListPtr => fieldCursor % recvList(iHalo)
+ exchListPtr => fieldCursor % recvList % halos(iHalo) % exchList
do while(associated(exchListPtr))
if(exchListPtr % endPointID == commListPtr % procID) then
do i = 1, exchListPtr % nList
@@ -3884,8 +4011,38 @@
call mpas_dmpar_destroy_communication_list(recvList)
#endif
+ deallocate(haloLayers)
+
end subroutine mpas_dmpar_exch_halo_field3d_real!}}}
+ subroutine mpas_dmpar_init_mulithalo_exchange_list(exchList, nHalos)!{{{
+ type (mpas_multihalo_exchange_list), pointer :: exchList
+ integer, intent(in) :: nHalos
+
+ integer :: i
+
+ allocate(exchList)
+ allocate(exchList % halos(nHalos))
+ do i = 1, nHalos
+ nullify(exchList % halos(i) % exchList)
+ end do
+ end subroutine mpas_dmpar_init_mulithalo_exchange_list!}}}
+
+ subroutine mpas_dmpar_destroy_mulithalo_exchange_list(exchList)!{{{
+ type (mpas_multihalo_exchange_list), pointer :: exchList
+
+ integer :: nHalos
+ integer :: i
+
+ do i = 1, nHalos
+ call mpas_dmpar_destroy_exchange_list(exchList % halos(i) % exchList)
+ end do
+
+ deallocate(exchList % halos)
+ deallocate(exchList)
+ nullify(exchList)
+ end subroutine mpas_dmpar_destroy_mulithalo_exchange_list!}}}
+
subroutine mpas_dmpar_destroy_communication_list(commList)!{{{
type (mpas_communication_list), pointer :: commList
type (mpas_communication_list), pointer :: commListPtr
@@ -3898,16 +4055,17 @@
nullify(commList)
end if
- if(allocated(commListPtr % ibuffer)) then
+ if(associated(commListPtr % ibuffer)) then
deallocate(commListPtr % ibuffer)
end if
- if(allocated(commListPtr % rbuffer)) then
+ if(associated(commListPtr % rbuffer)) then
deallocate(commListPtr % rbuffer)
end if
deallocate(commListPtr)
- commListPtr => recvList
+ commListPtr => commList
end do
+
end subroutine mpas_dmpar_destroy_communication_list!}}}
subroutine mpas_dmpar_destroy_exchange_list(exchList)!{{{
@@ -3922,11 +4080,11 @@
nullify(exchList)
end if
- if(allocated(exchListPtr % srcList)) then
+ if(associated(exchListPtr % srcList)) then
deallocate(exchListPtr % srcList)
end if
- if(allocated(exchListPtr % destList)) then
+ if(associated(exchListPtr % destList)) then
deallocate(exchListPtr % destList)
end if
Modified: branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar_types.F
===================================================================
--- branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar_types.F 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/framework/mpas_dmpar_types.F 2012-05-22 20:50:11 UTC (rev 1930)
@@ -3,21 +3,50 @@
use mpas_kind_types
type dm_info
- integer :: nprocs, my_proc_id, comm, info
- logical :: using_external_comm
+ integer :: nprocs, my_proc_id, comm, info
+ logical :: using_external_comm
end type dm_info
type exchange_list
- integer :: procID
- integer :: blockID
- integer :: nlist
- integer, dimension(:), pointer :: list
- type (exchange_list), pointer :: next
- real (kind=RKIND), dimension(:), pointer :: rbuffer
- integer, dimension(:), pointer :: ibuffer
- integer :: reqID
+ integer :: procID
+ integer :: blockID
+ integer :: nlist
+ integer, dimension(:), pointer :: list
+ type (mpas_exchange_list), pointer :: next
+ real (kind=RKIND), dimension(:), pointer :: rbuffer
+ integer, dimension(:), pointer :: ibuffer
+ integer :: reqID
end type exchange_list
+ type mpas_exchange_list
+ integer :: endPointID
+ integer :: nlist
+ integer, dimension(:), pointer :: srcList
+ integer, dimension(:), pointer :: destList
+ type (mpas_exchange_list), pointer :: next
+
+ end type mpas_exchange_list
+
+ type mpas_exchange_list_pointer
+ type (mpas_exchange_list), pointer :: exchList
+ end type mpas_exchange_list_pointer
+
+ type mpas_multihalo_exchange_list
+ type (mpas_exchange_list_pointer), dimension(:), pointer :: halos
+ end type mpas_multihalo_exchange_list
+
+
+ type mpas_communication_list
+ integer :: procID
+ integer :: nlist
+ real (kind=RKIND), dimension(:), pointer :: rbuffer
+ integer, dimension(:), pointer :: ibuffer
+ integer :: reqID
+ type (mpas_communication_list), pointer :: next
+
+ end type mpas_communication_list
+
+
end module mpas_dmpar_types
Modified: branches/omp_blocks/multiple_blocks/src/framework/mpas_grid_types.F
===================================================================
--- branches/omp_blocks/multiple_blocks/src/framework/mpas_grid_types.F 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/framework/mpas_grid_types.F 2012-05-22 20:50:11 UTC (rev 1930)
@@ -44,9 +44,9 @@
type (field3DReal), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field3DReal
@@ -73,9 +73,9 @@
type (field2DReal), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field2DReal
@@ -102,9 +102,9 @@
type (field1DReal), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field1DReal
@@ -129,9 +129,9 @@
type (field0DReal), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field0DReal
@@ -158,9 +158,9 @@
type (field3DInteger), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field3DInteger
@@ -187,9 +187,9 @@
type (field2DInteger), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field2DInteger
@@ -216,9 +216,9 @@
type (field1DInteger), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field1DInteger
@@ -243,9 +243,9 @@
type (field0DInteger), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field0DInteger
@@ -272,9 +272,9 @@
type (field1DChar), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field1DChar
@@ -299,9 +299,9 @@
type (field0DChar), pointer :: prev, next
! Halo communication lists
- type (exchange_list), dimension(:), pointer :: sendList
- type (exchange_list), dimension(:), pointer :: recvList
- type (exchange_list), dimension(:), pointer :: copyList
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
end type field0DChar
@@ -325,17 +325,17 @@
! Type for storing (possibly architecture specific) information concerning to parallelism
type parallel_info
- type (exchange_list), dimension(:), pointer :: cellsToSend ! List of types describing which cells to send to other blocks
- type (exchange_list), dimension(:), pointer :: cellsToRecv ! List of types describing which cells to receive from other blocks
- type (exchange_list), dimension(:), pointer :: cellsToCopy ! List of types describing which cells to copy from other blocks
+ type (mpas_multihalo_exchange_list), pointer :: cellsToSend ! List of types describing which cells to send to other blocks
+ type (mpas_multihalo_exchange_list), pointer :: cellsToRecv ! List of types describing which cells to receive from other blocks
+ type (mpas_multihalo_exchange_list), pointer :: cellsToCopy ! List of types describing which cells to copy from other blocks
- type (exchange_list), dimension(:), pointer :: edgesToSend ! List of types describing which edges to send to other blocks
- type (exchange_list), dimension(:), pointer :: edgesToRecv ! List of types describing which edges to receive from other blocks
- type (exchange_list), dimension(:), pointer :: edgesToCopy ! List of types describing which edges to copy from other blocks
+ type (mpas_multihalo_exchange_list), pointer :: edgesToSend ! List of types describing which edges to send to other blocks
+ type (mpas_multihalo_exchange_list), pointer :: edgesToRecv ! List of types describing which edges to receive from other blocks
+ type (mpas_multihalo_exchange_list), pointer :: edgesToCopy ! List of types describing which edges to copy from other blocks
- type (exchange_list), dimension(:), pointer :: verticesToSend ! List of types describing which vertices to send to other blocks
- type (exchange_list), dimension(:), pointer :: verticesToRecv ! List of types describing which vertices to receive from other blocks
- type (exchange_list), dimension(:), pointer :: verticesToCopy ! List of types describing which vertices to copy from other blocks
+ type (mpas_multihalo_exchange_list), pointer :: verticesToSend ! List of types describing which vertices to send to other blocks
+ type (mpas_multihalo_exchange_list), pointer :: verticesToRecv ! List of types describing which vertices to receive from other blocks
+ type (mpas_multihalo_exchange_list), pointer :: verticesToCopy ! List of types describing which vertices to copy from other blocks
end type parallel_info
@@ -394,19 +394,19 @@
end subroutine mpas_allocate_domain
- subroutine mpas_allocate_block(b, dom, blockID, &
+ subroutine mpas_allocate_block(nHaloLayers, b, dom, blockID, &
#include "dim_dummy_args.inc"
)
implicit none
+ integer, intent(in) :: nHaloLayers
type (block_type), pointer :: b
type (domain_type), pointer :: dom
integer, intent(in) :: blockID
#include "dim_dummy_decls.inc"
- integer, parameter :: nHaloLayers = 2
integer :: i
@@ -417,17 +417,17 @@
allocate(b % parinfo)
- allocate(b % parinfo % cellsToSend(nHaloLayers))
- allocate(b % parinfo % cellsToRecv(nHaloLayers))
- allocate(b % parinfo % cellsToCopy(nHaloLayers))
+ allocate(b % parinfo % cellsToSend % halos(nHaloLayers))
+ allocate(b % parinfo % cellsToRecv % halos(nHaloLayers))
+ allocate(b % parinfo % cellsToCopy % halos(nHaloLayers))
- allocate(b % parinfo % edgesToSend(nHaloLayers + 1)) ! first index is owned-cell edges
- allocate(b % parinfo % edgesToRecv(nHaloLayers + 1)) ! first index is owned-cell edges
- allocate(b % parinfo % edgesToCopy(nHaloLayers + 1)) ! first index is owned-cell edges
+ allocate(b % parinfo % edgesToSend % halos(nHaloLayers + 1)) ! first index is owned-cell edges
+ allocate(b % parinfo % edgesToRecv % halos(nHaloLayers + 1)) ! first index is owned-cell edges
+ allocate(b % parinfo % edgesToCopy % halos(nHaloLayers + 1)) ! first index is owned-cell edges
- allocate(b % parinfo % verticesToSend(nHaloLayers + 1)) ! first index is owned-cell vertices
- allocate(b % parinfo % verticesToRecv(nHaloLayers + 1)) ! first index is owned-cell vertices
- allocate(b % parinfo % verticesToCopy(nHaloLayers + 1)) ! first index is owned-cell vertices
+ allocate(b % parinfo % verticesToSend % halos(nHaloLayers + 1)) ! first index is owned-cell vertices
+ allocate(b % parinfo % verticesToRecv % halos(nHaloLayers + 1)) ! first index is owned-cell vertices
+ allocate(b % parinfo % verticesToCopy % halos(nHaloLayers + 1)) ! first index is owned-cell vertices
b % domain => dom
Modified: branches/omp_blocks/multiple_blocks/src/framework/mpas_io_input.F
===================================================================
--- branches/omp_blocks/multiple_blocks/src/framework/mpas_io_input.F 2012-05-22 18:29:36 UTC (rev 1929)
+++ branches/omp_blocks/multiple_blocks/src/framework/mpas_io_input.F 2012-05-22 20:50:11 UTC (rev 1930)
@@ -3,6 +3,7 @@
use mpas_grid_types
use mpas_dmpar
use mpas_block_decomp
+ use mpas_block_creator
use mpas_sort
use mpas_configure
use mpas_timekeeping
@@ -27,11 +28,11 @@
end type io_input_object
- type (exchange_list), pointer :: sendListPtr, recvListPtr, copyListPtr
- type (exchange_list), pointer :: sendCellList, recvCellList
- type (exchange_list), pointer :: sendEdgeList, recvEdgeList
- type (exchange_list), pointer :: sendVertexList, recvVertexList
- type (exchange_list), pointer :: sendVertLevelList, recvVertLevelList
+ type (mpas_exchange_list), pointer :: sendListPtr, recvListPtr, copyListPtr
+ type (mpas_exchange_list), pointer :: sendCellList, recvCellList
+ type (mpas_exchange_list), pointer :: sendEdgeList, recvEdgeList
+ type (mpas_exchange_list), pointer :: sendVertexList, recvVertexList
+ type (mpas_exchange_list), pointer :: sendVertLevelList, recvVertLevelList
integer :: readCellStart, readCellEnd, nReadCells
integer :: readEdgeStart, readEdgeEnd, nReadEdges
@@ -42,7 +43,7 @@
contains
subroutine mpas_input_state_for_domain(domain)!{{{
-
+
implicit none
type (domain_type), pointer :: domain
@@ -128,8 +129,8 @@
integer, dimension(:), pointer :: block_id, block_start, block_count
integer, dimension(:), pointer :: local_vertlevel_list, needed_vertlevel_list
integer :: nlocal_edges, nlocal_vertices
- type (exchange_list), pointer :: send1Halo, recv1Halo
- type (exchange_list), pointer :: send2Halo, recv2Halo
+ type (mpas_exchange_list), pointer :: send1Halo, recv1Halo
+ type (mpas_exchange_list), pointer :: send2Halo, recv2Halo
type (graph) :: partial_global_graph_info
type (graph) :: block_graph_0Halo, block_graph_1Halo, block_graph_2Halo
integer :: ghostEdgeStart, ghostVertexStart
@@ -146,14 +147,14 @@
character(len=32) :: timeStamp
character(len=1024) :: filename
- integer, parameter :: nHalos = 2
- integer, dimension(nHalos+1) :: nCellsCumulative ! own cells, halo 1 cells, halo 2 cells
- integer, dimension(nHalos+2) :: nEdgesCumulative ! own edges, own cell's edges, halo 1 edges, halo 2 edges
- integer, dimension(nHalos+2) :: nVerticesCumulative ! own vertices, own cell's vertices, halo 1 vertices, halo 2 vertices
+ integer :: nHalos
+ integer, dimension(config_num_halos+1) :: nCellsCumulative ! own cells, halo 1 cells, halo 2 cells
+ integer, dimension(config_num_halos+2) :: nEdgesCumulative ! own edges, own cell's edges, halo 1 edges, halo 2 edges
+ integer, dimension(config_num_halos+2) :: nVerticesCumulative ! own vertices, own cell's vertices, halo 1 vertices, halo 2 vertices
- integer, dimension(nHalos) :: nCellsHalo ! halo 1 cells, halo 2 cells
- integer, dimension(nHalos+1) :: nEdgesHalo ! own cell's edges, halo 1 edges, halo 2 edges
- integer, dimension(nHalos+1) :: nVerticesHalo ! own cell's vertices, halo 1 vertices, halo 2 vertices
+ integer, dimension(config_num_halos) :: nCellsHalo ! halo 1 cells, halo 2 cells
+ integer, dimension(config_num_halos+1) :: nEdgesHalo ! own cell's edges, halo 1 edges, halo 2 edges
+ integer, dimension(config_num_halos+1) :: nVerticesHalo ! own cell's vertices, halo 1 vertices, halo 2 vertices
integer, dimension(:), pointer :: tempIDs
integer :: ntempIDs, offset
@@ -161,7 +162,9 @@
integer :: nHalo, nOwnCells, nOwnEdges, nOwnVertices, cellCount, edgeCount, vertexCount, iEdge, iVertex
type (hashtable) :: edgeHash, vertexHash
+ nHalos = config_num_halos
+
if (config_do_restart) then
! this get followed by set is to ensure that the time is in standard format
@@ -214,6 +217,7 @@
nReadVertLevels = nVertLevels
allocate(readingBlock)
+ readingBlock % domain => domain
readingBlock % blockID = domain % dminfo % my_proc_id
readingBlock % localBlockID = 0
@@ -239,6 +243,20 @@
call mpas_io_get_var(inputHandle, 'indexToCellID', indexToCellIDField % array, ierr)
indexToCellIDField % dimSizes(1) = nReadCells
indexToCellIDField % block => readingBlock
+! call mpas_dmpar_init_multihalo_exchange_list(indexToCellIDField % sendList, nHalos)
+! call mpas_dmpar_init_mulithalo_exchange_list(indexToCellIDField % recvList, nHalos)
+! call mpas_dmpar_init_multihalo_exchange_list(indexToCellIDField % copyList, nHalos)
+ allocate(indexToCellIDField % sendList)
+ allocate(indexToCellIDField % recvList)
+ allocate(indexToCellIDField % copyList)
+ allocate(indexToCellIDField % sendList % halos(nHalos))
+ allocate(indexToCellIDField % recvList % halos(nHalos))
+ allocate(indexToCellIDField % copyList % halos(nHalos))
+ do i = 1, nHalos
+ nullify(indexToCellIDField % sendList % halos(i) % exchList)
+ nullify(indexToCellIDField % recvList % halos(i) % exchList)
+ nullify(indexToCellIDField % copyList % halos(i) % exchList)
+ end do
nullify(indexToCellIDField % next)
#ifdef HAVE_ZOLTAN
@@ -255,6 +273,9 @@
call mpas_io_get_var(inputHandle, 'xCell', xCellField % array, ierr)
xCellField % dimSizes(1) = nReadCells
xCellField % block => readingBlock
+ xCellField % sendList => indexToCellIDField % sendList
+ xCellField % recvList => indexToCellIDField % recvList
+ xCellField % copyList => indexToCellIDField % copyList
nullify(xCellField % next)
! Cell y-coordinates (in 3d Cartesian space)
@@ -267,6 +288,9 @@
call MPAS_io_inq_var(inputHandle, 'yCell', ierr=ierr)
call MPAS_io_set_var_indices(inputHandle, 'yCell', readIndices, ierr=ierr)
call mpas_io_get_var(inputHandle, 'yCell', yCellField % array, ierr)
+ yCellField % sendList => indexToCellIDField % sendList
+ yCellField % recvList => indexToCellIDField % recvList
+ yCellField % copyList => indexToCellIDField % copyList
yCellField % dimSizes(1) = nReadCells
yCellField % block => readingBlock
nullify(yCellField % next)
@@ -283,6 +307,9 @@
call mpas_io_get_var(inputHandle, 'zCell', zCellField % array, ierr)
zCellField % dimSizes(1) = nReadCells
zCellField % block => readingBlock
+ zCellField % sendList => indexToCellIDField % sendList
+ zCellField % recvList => indexToCellIDField % recvList
+ zCellField % copyList => indexToCellIDField % copyList
nullify(zCellField % next)
#endif
#endif
@@ -306,6 +333,17 @@
call mpas_io_get_var(inputHandle, 'indexToEdgeID', indexToEdgeIDField % array, ierr)
indexToEdgeIDField % dimSizes(1) = nREadEdges
indexToEdgeIDField % block => readingBlock
+ allocate(indexToEdgeIDField % sendList)
+ allocate(indexToEdgeIDField % recvList)
+ allocate(indexToEdgeIDField % copyList)
+ allocate(indexToEdgeIDField % sendList % halos(nHalos))
+ allocate(indexToEdgeIDField % recvList % halos(nHalos))
+ allocate(indexToEdgeIDField % copyList % halos(nHalos))
+ do i = 1, nHalos
+ nullify(indexToEdgeIDField % sendList % halos(i) % exchList)
+ nullify(indexToEdgeIDField % recvList % halos(i) % exchList)
+ nullify(indexToEdgeIDField % copyList % halos(i) % exchList)
+ end do
nullify(indexToEdgeIDField % next)
#ifdef HAVE_ZOLTAN
@@ -322,6 +360,9 @@
call mpas_io_get_var(inputHandle, 'xEdge', xEdgeField % array, ierr)
xEdgeField % dimSizes(1) = nReadEdges
xEdgeField % block => readingBlock
+ xEdgeField % sendList => indexToEdgeIDField % sendList
+ xEdgeField % recvList => indexToEdgeIDField % recvList
+ xEdgeField % copyList => indexToEdgeIDField % copyList
nullify(xEdgeField % next)
! Edge y-coordinates (in 3d Cartesian space)
@@ -336,6 +377,9 @@
call mpas_io_get_var(inputHandle, 'yEdge', yEdgeField % array, ierr)
yEdgeField % dimSizes(1) = nReadEdges
yEdgeField % block => readingBlock
+ yEdgeField % sendList => indexToEdgeIDField % sendList
+ yEdgeField % recvList => indexToEdgeIDField % recvList
+ yEdgeField % copyList => indexToEdgeIDField % copyList
nullify(yEdgeField % next)
! Edge z-coordinates (in 3d Cartesian space)
@@ -350,6 +394,9 @@
call mpas_io_get_var(inputHandle, 'zEdge', zEdgeField % array, ierr)
zEdgeField % dimSizes(1) = nReadEdges
zEdgeField % block => readingBlock
+ zEdgeField % sendList => indexToEdgeIDField % sendList
+ zEdgeField % recvList => indexToEdgeIDField % recvList
+ zEdgeField % copyList => indexToEdgeIDField % copyList
nullify(zEdgeField % next)
#endif
#endif
@@ -372,6 +419,17 @@
call mpas_io_get_var(inputHandle, 'indexToVertexID', indexToVertexIDField % array, ierr)
indexToVertexIDField % dimSizes(1) = nReadVertices
indexToVertexIDField % block => readingBlock
+ allocate(indexToVertexIDField % sendList)
+ allocate(indexToVertexIDField % recvList)
+ allocate(indexToVertexIDField % copyList)
+ allocate(indexToVertexIDField % sendList % halos(nHalos))
+ allocate(indexToVertexIDField % recvList % halos(nHalos))
+ allocate(indexToVertexIDField % copyList % halos(nHalos))
+ do i = 1, nHalos
+ nullify(indexToVertexIDField % sendList % halos(i) % exchList)
+ nullify(indexToVertexIDField % recvList % halos(i) % exchList)
+ nullify(indexToVertexIDField % copyList % halos(i) % exchList)
+ end do
nullify(indexToVertexIDField % next)
#ifdef HAVE_ZOLTAN
@@ -388,6 +446,9 @@
call mpas_io_get_var(inputHandle, 'xVertex', xVertexField % array, ierr)
xVertexField % dimSizes(1) = nReadVertices
xVertexField % block => readingBlock
+ xVertexField % sendList => indexToVertexIDField % sendList
+ xVertexField % recvList => indexToVertexIDField % recvList
+ xVertexField % copyList => indexToVertexIDField % copyList
nullify(xVertexField % next)
! Vertex y-coordinates (in 3d Cartesian space)
@@ -402,6 +463,9 @@
call mpas_io_get_var(inputHandle, 'yVertex', yVertexField % array, ierr)
yVertexField % dimSizes(1) = nReadVertices
yVertexField % block => readingBlock
+ yVertexField % sendList => indexToVertexIDField % sendList
+ yVertexField % recvList => indexToVertexIDField % recvList
+ yVertexField % copyList => indexToVertexIDField % copyList
nullify(yVertexField % next)
! Vertex z-coordinates (in 3d Cartesian space)
@@ -416,6 +480,9 @@
call mpas_io_get_var(inputHandle, 'zVertex', zVertexField % array, ierr)
zVertexField % dimSizes(1) = nReadVertices
zVertexField % block => readingBlock
+ zVertexField % sendList => indexToVertexIDField % sendList
+ zVertexField % recvList => indexToVertexIDField % recvList
+ zVertexField % copyList => indexToVertexIDField % copyList
nullify(zVertexField % next)
#endif
#endif
@@ -437,6 +504,9 @@
call mpas_io_get_var(inputHandle, 'nEdgesOnCell', nEdgesOnCellField % array, ierr)
nEdgesOnCellField % dimSizes(1) = nReadCells
nEdgesOnCellField % block => readingBlock
+ nEdgesOnCellField % sendList => indexToCellIDField % sendList
+ nEdgesOnCellField % recvList => indexToCellIDField % recvList
+ nEdgesOnCellField % copyList => indexToCellIDField % copyList
nullify(nEdgesOnCellField % next)
! Global indices of cells adjacent to each cell
@@ -454,6 +524,9 @@
cellsOnCellField % dimSizes(1) = maxEdges
cellsOnCellField % dimSizes(2) = nReadCells
cellsOnCellField % block => readingBlock
+ cellsOnCellField % sendList => indexToCellIDField % sendList
+ cellsOnCellField % recvList => indexToCellIDField % recvList
+ cellsOnCellField % copyList => indexToCellIDField % copyList
nullify(cellsOnCellField % next)
! Global indices of edges adjacent to each cell
@@ -471,6 +544,9 @@
edgesOnCellField % dimSizes(1) = maxEdges
edgesOnCellField % dimSizes(2) = nReadCells
edgesOnCellField % block => readingBlock
+ edgesOnCellField % sendList => indexToCellIDField % sendList
+ edgesOnCellField % recvList => indexToCellIDField % recvList
+ edgesOnCellField % copyList => indexToCellIDField % copyList
nullify(edgesOnCellField % next)
! Global indices of vertices adjacent to each cell
@@ -489,6 +565,9 @@
verticesOnCellField % dimSizes(1) = maxEdges
verticesOnCellField % dimSizes(2) = nReadCells
verticesOnCellField % block => readingBlock
+ verticesOnCellField % sendList => indexToCellIDField % sendList
+ verticesOnCellField % recvList => indexToCellIDField % recvList
+ verticesOnCellField % copyList => indexToCellIDField % copyList
nullify(verticesOnCellField % next)
@@ -515,6 +594,9 @@
cellsOnEdgeField % dimSizes(1) = 2
cellsOnEdgeField % dimSizes(1) = nReadEdges
cellsOnEdgeField % block => readingBlock
+ cellsOnEdgeField % sendList => indexToEdgeIDField % sendList
+ cellsOnEdgeField % recvList => indexToEdgeIDField % recvList
+ cellsOnEdgeField % copyList => indexToEdgeIDField % copyList
nullify(cellsOnEdgeField % next)
@@ -539,6 +621,9 @@
cellsOnVertexField % dimSizes(1) = vertexDegree
cellsOnVertexField % dimSizes(2) = nReadVertices
cellsOnVertexField % block => readingBlock
+ cellsOnVertexField % sendList => indexToEdgeIDField % sendList
+ cellsOnVertexField % recvList => indexToEdgeIDField % recvList
+ cellsOnVertexField % copyList => indexToEdgeIDField % copyList
nullify(cellsOnVertexField % next)
deallocate(readIndices)
@@ -576,113 +661,15 @@
deallocate(partial_global_graph_info % nAdjacent)
deallocate(partial_global_graph_info % adjacencyList)
- nBlocksLocal = size(block_id)
- call mpas_dmpar_max_int(domain % dminfo, nBlocksLocal, nBlocksMax)
+ write(6,*) 'calling setup blocks and 0halo cells'
+ call mpas_block_creator_setup_blocks_and_0halo_cells(domain, indexToCellID_0Halo, local_cell_list, block_id, block_start, block_count)
+ write(6,*) 'calling build 0halo cell fields'
+ call mpas_block_creator_build_0halo_cell_fields(indexToCellIDField, nEdgesOnCellField, cellsOnCellField, indexToCellID_0Halo, nEdgesOnCell_0Halo, cellsOnCell_0Halo)
+ write(6,*) 'Done with 0 halo cells'
- allocate(offSetField)
- allocate(indexToCellID_0Halo)
- allocate(domain % blocklist)
+ write(6,*) 'Stopping'
+ stop
- write(6,*) 'setting up 0 halo fields'
-
- block_ptr => domain % blocklist
- int1d_ptr => indexToCellID_0Halo
- int0d_ptr => offSetField
- do iBlock = 1, nBlocksLocal
- nCellsInBlock = block_count(iBlock)
-
- block_ptr % blockID = block_id(iBlock)
- block_ptr % localBlockID = iBlock-1
-
- int1d_ptr % block => block_ptr
- int1d_ptr % dimSizes(1) = nCellsInBlock
-
- int0d_ptr % block => block_ptr
- int0d_ptr % scalar = nCellsInBlock
- allocate(int1d_ptr % array(nCellsInBlock))
- do i = 1, nCellsInBlock
- int1d_ptr % array(i) = local_cell_list(block_start(iBlock) + i)
- end do
-
- if(iBlock < nBlocksLocal) then
- allocate(block_ptr % next)
- allocate(int1d_ptr % next)
- block_ptr % next % prev => block_ptr
- block_ptr => block_ptr % next
- int1d_ptr => int1d_ptr % next
- end if
-
- nullify(block_ptr % next)
- nullify(int1d_ptr % next)
- end do
-
- allocate(nEdgesOnCell_0Halo)
- allocate(cellsOnCell_0Halo)
- allocate(verticesOnCell_0Halo)
-
- block_ptr => domain % blocklist
- int1d_ptr => nEdgesOnCell_0Halo
- int2d_ptr => cellsOnCell_0Halo
- int2d_ptr2 => verticesOnCell_0Halo
-
- do while(associated(block_ptr))
- nCellsInBlock = block_count(block_ptr % localBlockID + 1)
-
- allocate(int1d_ptr % array(nCellsInBlock))
- allocate(int2d_ptr % array(maxEdges, nCellsInBlock))
- allocate(int2d_ptr2 % array(maxEdges, nCellsInBlock))
-
- int1d_ptr % block => block_ptr
- int2d_ptr % block => block_ptr
- int2d_ptr2 % block => block_ptr
- int1d_ptr % dimSizes(1) = nCellsInBlock
- int2d_ptr % dimSizes(1) = maxEdges
- int2d_ptr % dimSizes(2) = nCellsInBlock
- int2d_ptr2 % dimSizes(1) = maxEdges
- int2d_ptr2 % dimSizes(2) = nCellsInBlock
-
- block_ptr => block_ptr % next
- if(associated(block_ptr)) then
- allocate(int1d_ptr % next)
- allocate(int2d_ptr % next)
- allocate(int2d_ptr2 % next)
- int1d_ptr => int1d_ptr % next
- int2d_ptr => int2d_ptr % next
- int2d_ptr2 => int2d_ptr2 % next
- end if
-
- nullify(int1d_ptr % next)
- nullify(int2d_ptr % next)
- nullify(int2d_ptr2 % next)
- end do
-
- !
- ! Now that each process has a list of cells that it owns, exchange cell connectivity
- ! information between the processes that read info for a cell and those that own that cell
- !
-
- write(6,*) 'setup 0 halo exchange lists'
- call mpas_get_exchange_lists(domain % dminfo, indexToCellIDField, .false., indexToCellID_0Halo, .true.)
-
-
- write(6,*) 'link 0 halo exchange lists 1'
- call mpas_link_exchange_list_field(indexToCellIDField, indexToCellID_0Halo, nEdgesOnCellField, nEdgesOnCell_0Halo)
- write(6,*) 'link 0 halo exchange lists 2'
- call mpas_link_exchange_list_field(indexToCellIDField, indexToCellID_0Halo, cellsOnCellField, cellsOnCell_0Halo)
- write(6,*) 'link 0 halo exchange lists 3'
- call mpas_link_exchange_list_field(indexToCellIDField, indexToCellID_0Halo, verticesOnCellField, verticesOnCell_0Halo)
-
- write(6,*) '0 halo all to all 1'
- call mpas_dmpar_alltoall_field(domain % dminfo, indexToCellIDField, indexToCellID_0Halo)
- write(6,*) '0 halo all to all 2'
- call mpas_dmpar_alltoall_field(domain % dminfo, nEdgesOnCellField, nEdgesOnCell_0Halo)
- write(6,*) '0 halo all to all 3'
- call mpas_dmpar_alltoall_field(domain % dminfo, cellsOnCellField, cellsOnCell_0Halo)
- write(6,*) '0 halo all to all 4'
- call mpas_dmpar_alltoall_field(domain % dminfo, verticesOnCellField, verticesOnCell_0Halo)
-
- write(6,*) 'Done with 0 halo'
-
! write(6,*) 'Building temporary indexToVertexID list. Containing 0 and 1 halo vertices'
! allocate(indexToVertexID_tList)
! int1d_ptr => nEdgesOnCell_0Halo
@@ -805,9 +792,6 @@
! deallocate(recvCellList % list)
! deallocate(recvCellList)
- write(6,*) 'Trying new halo routine'
- call mpas_get_halo_cells_and_exchange_lists(domain % dminfo, nHalos, indexToCellID_0Halo, nEdgesOnCell_0Halo, cellsOnCell_0Halo, indexToCellID_Halos, nEdgesOnCell_Halos, cellsOnCell_Halos)
-
! call mpas_get_vertex_ids_and_exchange_lists(domain % dminfo, nHalos, maxEdges, vertexDegree, indexToCellID_0Halo, nEdgesOnCell_0Halo
! block_ptr => domain % blocklist
@@ -836,9 +820,6 @@
! end do
! block_ptr => block_ptr % next
! end do
-
- write(6,*) 'Stopping'
- stop
!#ifdef HAVE_ZOLTAN
!#ifdef _MPI
@@ -1141,7 +1122,7 @@
! nEdges = nlocal_edges
! nVertices = nlocal_vertices
!
-! call mpas_allocate_block(domain % blocklist, domain, domain%dminfo%my_proc_id, &
+! call mpas_allocate_block(nHalos, domain % blocklist, domain, domain%dminfo%my_proc_id, &
!#include "dim_dummy_args.inc"
! )
!
</font>
</pre>