<p><b>duda</b> 2012-04-24 17:11:28 -0600 (Tue, 24 Apr 2012)</p><p>Merge branches/omp_blocks/io to the trunk.<br>
</p><hr noshade><pre><font color="gray">Modified: trunk/mpas/Makefile
===================================================================
--- trunk/mpas/Makefile 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/Makefile 2012-04-24 23:11:28 UTC (rev 1802)
@@ -25,6 +25,9 @@
"FFLAGS_OPT = -O3 -qrealsize=8" \
"CFLAGS_OPT = -O3" \
"LDFLAGS_OPT = -O3" \
+ "FFLAGS_DEBUG = -O0 -g -C -qrealsize=8" \
+ "CFLAGS_DEBUG = -O0 -g" \
+ "LDFLAGS_DEBUG = -O0 -g" \
"CORE = $(CORE)" \
"DEBUG = $(DEBUG)" \
"SERIAL = $(SERIAL)" \
@@ -190,9 +193,9 @@
"USE_PAPI = $(USE_PAPI)" \
"CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-CPPINCLUDES = -I../inc -I$(NETCDF)/include
-FCINCLUDES = -I../inc -I$(NETCDF)/include
-LIBS = -L$(NETCDF)/lib -lnetcdf
+CPPINCLUDES = -I../inc -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include
+FCINCLUDES = -I../inc -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include
+LIBS = -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -lpio -lpnetcdf -lnetcdf
RM = rm -f
CPP = cpp -C -P -traditional
@@ -227,9 +230,9 @@
LDFLAGS=$(LDFLAGS_OPT)
DEBUG_MESSAGE="Debug flags are not defined for this compile group. Defaulting to Optimized flags"
else # FFLAGS_DEBUG IF
- FFLAGS=$(FFLAGS_DEBUG) -DMPAS_DEBUG
+ FFLAGS=$(FFLAGS_DEBUG)
CFLAGS=$(CFLAGS_DEBUG) -DMPAS_DEBUG
- LDFLAGS=$(LDFLAGS_DEBUG) -DMPAS_DEBUG
+ LDFLAGS=$(LDFLAGS_DEBUG)
DEBUG_MESSAGE="Debugging is on."
endif # FFLAGS_DEBUG IF
Modified: trunk/mpas/namelist.input
===================================================================
--- trunk/mpas/namelist.input 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input 2012-04-24 23:11:28 UTC (rev 1802)
@@ -1 +1 @@
-link namelist.input.ocean
\ No newline at end of file
+link namelist.input.sw
\ No newline at end of file
Modified: trunk/mpas/namelist.input.hyd_atmos
===================================================================
--- trunk/mpas/namelist.input.hyd_atmos 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input.hyd_atmos 2012-04-24 23:11:28 UTC (rev 1802)
@@ -26,8 +26,17 @@
config_restart_name = 'restart.nc'
config_output_interval = '1_00:00:00'
config_frames_per_outfile = 0
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
+&decomposition
+ config_number_of_blocks = 0
+ config_block_decomp_file_prefix = 'graph.info.part.'
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
+/
+
&restart
config_restart_interval = '1000_00:00:00'
config_do_restart = .false.
Modified: trunk/mpas/namelist.input.init_nhyd_atmos
===================================================================
--- trunk/mpas/namelist.input.init_nhyd_atmos 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input.init_nhyd_atmos 2012-04-24 23:11:28 UTC (rev 1802)
@@ -35,9 +35,17 @@
&io
config_input_name = 'x1.40962.geogrid.nc'
config_output_name = 'x1.40962.init.2010-10-23.nc'
- config_decomp_file_prefix = 'x1.40962.graph.info.part.'
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
+&decomposition
+ config_number_of_blocks = 0
+ config_block_decomp_file_prefix = 'x1.40962.graph.info.part.'
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
+/
+
&restart
config_restart_interval = 3000
config_do_restart = .false.
Modified: trunk/mpas/namelist.input.nhyd_atmos
===================================================================
--- trunk/mpas/namelist.input.nhyd_atmos 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input.nhyd_atmos 2012-04-24 23:11:28 UTC (rev 1802)
@@ -45,10 +45,18 @@
config_restart_name = 'restart.nc'
config_output_interval = '1_00:00:00'
config_frames_per_outfile = 1
- config_decomp_file_prefix = 'x1.40962.graph.info.part.'
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
config_sfc_update_name = 'sfc_update.nc'
+&decomposition
+ config_number_of_blocks = 0
+ config_block_decomp_file_prefix = 'x1.40962.graph.info.part.'
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
+/
+
&restart
config_restart_interval = '1_00:00:00'
config_do_restart = .false.
Modified: trunk/mpas/namelist.input.nhyd_atmos_jw
===================================================================
--- trunk/mpas/namelist.input.nhyd_atmos_jw 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input.nhyd_atmos_jw 2012-04-24 23:11:28 UTC (rev 1802)
@@ -42,8 +42,17 @@
config_input_name = 'grid.nc'
config_output_name = 'output.nc'
config_restart_name = 'restart.nc'
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
+&decomposition
+ config_number_of_blocks = 0
+ config_block_decomp_file_prefix = 'graph.info.part.'
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
+/
+
&restart
config_restart_interval = 3000
config_do_restart = .false.
Modified: trunk/mpas/namelist.input.nhyd_atmos_mtn_wave
===================================================================
--- trunk/mpas/namelist.input.nhyd_atmos_mtn_wave 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input.nhyd_atmos_mtn_wave 2012-04-24 23:11:28 UTC (rev 1802)
@@ -38,8 +38,17 @@
config_restart_name = 'restart.nc'
config_output_interval = '00:30:00'
config_frames_per_outfile = 0
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
+&decomposition
+ config_number_of_blocks = 0
+ config_block_decomp_file_prefix = 'graph.info.part.'
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
+/
+
&restart
config_restart_interval = '1_00:00:00'
config_do_restart = .false.
Modified: trunk/mpas/namelist.input.nhyd_atmos_squall
===================================================================
--- trunk/mpas/namelist.input.nhyd_atmos_squall 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input.nhyd_atmos_squall 2012-04-24 23:11:28 UTC (rev 1802)
@@ -38,8 +38,17 @@
config_restart_name = 'restart.nc'
config_output_interval = '00:30:00'
config_frames_per_outfile = 0
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
+&decomposition
+ config_number_of_blocks = 0
+ config_block_decomp_file_prefix = 'graph.info.part.'
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
+/
+
&restart
config_restart_interval = '1_00:00:00'
config_do_restart = .false.
Modified: trunk/mpas/namelist.input.ocean
===================================================================
--- trunk/mpas/namelist.input.ocean 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input.ocean 2012-04-24 23:11:28 UTC (rev 1802)
@@ -13,7 +13,15 @@
config_restart_name = 'restart.nc'
config_output_interval = '1_00:00:00'
config_frames_per_outfile = 1000000
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
+&decomposition
+ config_number_of_blocks = 0
+ config_block_decomp_file_prefix = 'graph.info.part.'
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
+/
&restart
config_do_restart = .false.
config_restart_interval = '120_00:00:00'
Modified: trunk/mpas/namelist.input.sw
===================================================================
--- trunk/mpas/namelist.input.sw 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/namelist.input.sw 2012-04-24 23:11:28 UTC (rev 1802)
@@ -25,8 +25,15 @@
config_restart_name = 'restart.nc'
config_output_interval = '1_00:00:00'
config_frames_per_outfile = 0
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
-
+&decomposition
+ config_number_of_blocks = 0
+ config_block_decomp_file_prefix = 'graph.info.part.'
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
+/
&restart
config_restart_interval = '15_00:00:00'
config_do_restart = .false.
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_todynamics.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_todynamics.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_todynamics.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -12,21 +12,17 @@
contains
!=============================================================================================
- subroutine physics_addtend(dminfo,cellsToSend,cellsToRecv,mesh,state,diag,tend, &
- tend_physics,mass,mass_edge)
+subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edge)
!=============================================================================================
!input variables:
!----------------
- type(dm_info), intent(in):: dminfo
- type(mesh_type),intent(in):: mesh
- type(exchange_list),pointer:: cellsToSend,cellsToRecv
-
+type(mesh_type),intent(in):: mesh
type(state_type),intent(in):: state
type(diag_type),intent(in):: diag
- type(tend_physics_type),intent(in):: tend_physics
- real(kind=RKIND),dimension(:,:):: mass
- real(kind=RKIND),dimension(:,:):: mass_edge
+ type(tend_physics_type),intent(inout):: tend_physics
+ real(kind=RKIND),dimension(:,:),intent(in):: mass
+ real(kind=RKIND),dimension(:,:),intent(in):: mass_edge
!inout variables:
!----------------
@@ -34,6 +30,9 @@
!local variables:
!----------------
+
+ type(block_type),pointer :: block
+
integer:: i,iCell,k,n,nCells,nCellsSolve,nEdges,nEdgesSolve,nVertLevels
real(kind=RKIND),dimension(:,:),pointer:: theta_m,qv
@@ -56,6 +55,8 @@
!=============================================================================================
!write(0,*)
!write(0,*) '--- enter subroutine physics_add_tend:'
+
+ block => mesh % block
nCells = mesh % nCells
nEdges = mesh % nEdges
@@ -99,7 +100,7 @@
if(config_pbl_scheme .ne. 'off') then
allocate(rublten_Edge(nVertLevels,nEdges))
rublten_Edge(:,:) = 0.
- call tend_toEdges(dminfo,CellsToSend,CellsToRecv,mesh,rublten,rvblten,rublten_Edge)
+ call tend_toEdges(mesh,rublten,rvblten,rublten_Edge)
do i = 1, nEdgesSolve
do k = 1, nVertLevels
tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i)
@@ -185,15 +186,12 @@
end subroutine physics_addtend
!=============================================================================================
- subroutine tend_toEdges(dminfo,cellsToSend,cellsToRecv,mesh,Ux_tend,Uy_tend,U_tend)
+ subroutine tend_toEdges(mesh,Ux_tend,Uy_tend,U_tend)
!=============================================================================================
!input arguments:
!----------------
- type(dm_info),intent(in):: dminfo
type(mesh_type),intent(in):: mesh
- type(exchange_list),intent(in),pointer:: cellsToSend,cellsToRecv
-
real(kind=RKIND),intent(in),dimension(:,:):: Ux_tend,Uy_tend
!output arguments:
@@ -201,16 +199,21 @@
real(kind=RKIND),intent(out),dimension(:,:):: U_tend
!local variables:
+!-----------------
+ type(block_type),pointer :: block
+ type (field2DReal):: tempField
integer:: iCell,iEdge,k,j,nCells,nCellsSolve,nVertLevels
integer,dimension(:),pointer :: nEdgesOnCell
integer,dimension(:,:),pointer:: edgesOnCell
real(kind=RKIND),dimension(:,:),pointer:: east,north,edge_normal
- real(kind=RKIND),dimension(:,:),allocatable:: Ux_tend_halo,Uy_tend_halo
+ real(kind=RKIND),dimension(:,:),allocatable,target:: Ux_tend_halo,Uy_tend_halo
!---------------------------------------------------------------------------------------------
- nCells = mesh % nCells
+ block => mesh % block
+
+ nCells = mesh % nCells
nCellsSolve = mesh % nCellsSolve
nVertLevels = mesh % nVertLevels
@@ -232,11 +235,18 @@
enddo
enddo
- call mpas_dmpar_exch_halo_field2d_real( &
- dminfo,Ux_tend_halo,nVertLevels,nCells,cellsToSend,cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real( &
- dminfo,Uy_tend_halo,nVertLevels,nCells,cellsToSend,cellsToRecv)
+ tempField % block => block
+ tempField % dimSizes(1) = nVertLevels
+ tempField % dimSizes(2) = nCellsSolve
+ tempField % sendList => block % parinfo % cellsToSend
+ tempField % recvList => block % parinfo % cellsToRecv
+ tempField % array => Ux_tend_halo
+ call mpas_dmpar_exch_halo_field(tempField)
+
+ tempField % array => Uy_tend_halo
+ call mpas_dmpar_exch_halo_field(tempField)
+
U_tend(:,:) = 0.0
do iCell = 1, nCells
do j = 1, nEdgesOnCell(iCell)
Modified: trunk/mpas/src/core_hyd_atmos/Registry
===================================================================
--- trunk/mpas/src/core_hyd_atmos/Registry 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_hyd_atmos/Registry 2012-04-24 23:11:28 UTC (rev 1802)
@@ -27,7 +27,12 @@
namelist character io config_restart_name restart.nc
namelist character io config_output_interval 06:00:00
namelist integer io config_frames_per_outfile 0
-namelist character io config_decomp_file_prefix graph.info.part.
+namelist integer io config_pio_num_iotasks 0
+namelist integer io config_pio_stride 1
+namelist character decomposition config_block_decomp_file_prefix graph.info.part.
+namelist integer decomposition config_number_of_blocks 0
+namelist logical decomposition config_explicit_proc_decomp .false.
+namelist character decomposition config_proc_decomp_file_prefix graph.info.part.
namelist logical restart config_do_restart false
namelist character restart config_restart_interval none
Modified: trunk/mpas/src/core_hyd_atmos/mpas_atmh_mpas_core.F
===================================================================
--- trunk/mpas/src/core_hyd_atmos/mpas_atmh_mpas_core.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_hyd_atmos/mpas_atmh_mpas_core.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -3,7 +3,7 @@
use mpas_framework
use mpas_timekeeping
- type (io_output_object) :: restart_obj
+ type (io_output_object), save :: restart_obj
integer :: current_outfile_frames
Modified: trunk/mpas/src/core_hyd_atmos/mpas_atmh_time_integration.F
===================================================================
--- trunk/mpas/src/core_hyd_atmos/mpas_atmh_time_integration.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_hyd_atmos/mpas_atmh_time_integration.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -114,39 +114,17 @@
if(debug) write(0,*) ' rk substep ', rk_step
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % qtot % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % cqu % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pv_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- if (config_h_mom_eddy_visc4 > 0.0) then
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nVertices, &
- block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
- end if
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % mesh % qtot)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % mesh % cqu)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % h)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % pressure)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % geopotential)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % alpha)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % pv_edge)
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % divergence)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % vorticity)
+ end if
if(debug) write(0,*) ' rk substep ', rk_step
@@ -161,16 +139,8 @@
!
! --- update halos for tendencies
!
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % theta % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % u)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % theta)
! --- advance over sub_steps
@@ -208,52 +178,20 @@
!
! --- update halos for prognostic variables
!
- block => domain % blocklist
- do while (associated(block))
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % u % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nEdges, &
-!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % uhAvg % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nEdges, &
-!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % wwAvg % array(:,:), &
-!! block % mesh % nVertLevels+1, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % theta % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % mesh % dpsdt % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % state % time_levs(2) % state % surface_pressure % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % ww % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % pressure_old % array(:,:), &
-!! block % mesh % nVertLevels+1, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+!! call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % h_edge)
+!! call mpas_dmpar_exch_halo_field(domain % blocklist % mesh % uhAvg)
+!! call mpas_dmpar_exch_halo_field(domain % blocklist % mesh % wwAvg)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % theta)
+!! call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % h)
+!! call mpas_dmpar_exch_halo_field(domain % blocklist % tend % h)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % mesh % dpsdt)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % surface_pressure)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % alpha)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % ww)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % pressure)
+!! call mpas_dmpar_exch_halo_field(domain % blocklist % mesh % pressure_old)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % geopotential)
end do
@@ -274,24 +212,15 @@
block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
block % mesh, rk_timestep(rk_step) )
else
- call atmh_advance_scalars_mono( block % tend, &
- block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
- block % mesh, rk_timestep(rk_step), rk_step, 3, &
- domain % dminfo, block % parinfo % cellsToSend, block % parinfo % cellsToRecv )
+ call atmh_advance_scalars_mono(block % tend, &
+ block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
+ block % mesh, rk_timestep(rk_step), rk_step, 3)
end if
block => block % next
end do
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % scalars % array(:,:,:), &
- block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % state % time_levs(2) % state % scalars % array(:,:,:), &
- block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % scalars)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % scalars)
if(debug) write(0,*) ' advance scalars complete '
@@ -1461,7 +1390,7 @@
end subroutine atmh_advance_scalars
- subroutine atmh_advance_scalars_mono( tend, s_old, s_new, grid, dt, rk_step, rk_order, dminfo, cellsToSend, cellsToRecv)
+ subroutine atmh_advance_scalars_mono(tend, s_old, s_new, grid, dt, rk_step, rk_order)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Input: s - current model state
@@ -1476,11 +1405,11 @@
type (state_type), intent(in) :: s_old
type (state_type), intent(inout) :: s_new
type (mesh_type), intent(in) :: grid
- integer, intent(in) :: rk_step, rk_order
real (kind=RKIND), intent(in) :: dt
- type (dm_info), intent(in) :: dminfo
- type (exchange_list), pointer :: cellsToSend, cellsToRecv
+ integer, intent(in) :: rk_step, rk_order
+ type (block_type), pointer :: block
+
integer :: i, iCell, iEdge, k, iScalar, cell_upwind, cell1, cell2, num_scalars
real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
real (kind=RKIND) :: fdir, flux_upwind, h_flux_upwind, s_upwind
@@ -1491,9 +1420,11 @@
real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
integer, dimension(:,:), pointer :: cellsOnEdge
+ type (field3DReal) :: tempField
+
real (kind=RKIND), dimension( s_old % num_scalars, grid % nEdges+1) :: h_flux
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: v_flux, v_flux_upwind, s_update
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: scale_out, scale_in
+ real (kind=RKIND), dimension(2, s_old % num_scalars, grid % nCells+1) :: v_flux, v_flux_upwind, s_update
+ real (kind=RKIND), dimension(2, s_old % num_scalars, grid % nCells+1), target :: scale_out, scale_in
real (kind=RKIND), dimension( s_old % num_scalars ) :: s_max, s_min, s_max_update, s_min_update
integer :: nVertLevels, km0, km1, ktmp, kcp1, kcm1
@@ -1502,6 +1433,8 @@
real (kind=RKIND), parameter :: eps=1.e-20
real (kind=RKIND) :: coef_3rd_order
+ block => grid % block
+
num_scalars = s_old % num_scalars
scalar_old => s_old % scalars % array
@@ -1531,8 +1464,8 @@
km1 = 1
km0 = 2
- v_flux(:,:,km1) = 0.
- v_flux_upwind(:,:,km1) = 0.
+ v_flux(km1,:,:) = 0.
+ v_flux_upwind(km1,:,:) = 0.
scale_out(:,:,:) = 1.
scale_in(:,:,:) = 1.
@@ -1552,20 +1485,20 @@
cell_upwind = k
if (wwAvg(k+1,iCell) >= 0) cell_upwind = k+1
do iScalar=1,num_scalars
- v_flux(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * &
+ v_flux(km0,iScalar,iCell) = dt * wwAvg(k+1,iCell) * &
(fnm(k+1) * scalar_new(iScalar,k+1,iCell) + fnp(k+1) * scalar_new(iScalar,k,iCell))
- v_flux_upwind(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * scalar_old(iScalar,cell_upwind,iCell)
- v_flux(iScalar,iCell,km0) = v_flux(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km0)
+ v_flux_upwind(km0,iScalar,iCell) = dt * wwAvg(k+1,iCell) * scalar_old(iScalar,cell_upwind,iCell)
+ v_flux(km0,iScalar,iCell) = v_flux(km0, iScalar,iCell) - v_flux_upwind(km0,iScalar,iCell)
! v_flux(iScalar,iCell,km0) = 0. ! use only upwind - for testing
- s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
- - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
+ s_update(km0,iScalar,iCell) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
+ - rdnw(k) * (v_flux_upwind(km0,iScalar,iCell) - v_flux_upwind(km1,iScalar,iCell))
end do
else
do iScalar=1,num_scalars
- v_flux(iScalar,iCell,km0) = 0.
- v_flux_upwind(iScalar,iCell,km0) = 0.
- s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
- - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
+ v_flux(km0,iScalar,iCell) = 0.
+ v_flux_upwind(km0,iScalar,iCell) = 0.
+ s_update(km0,iScalar,iCell) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
+ - rdnw(k) * (v_flux_upwind(km0,iScalar,iCell) - v_flux_upwind(km1,iScalar,iCell))
end do
end if
@@ -1586,8 +1519,8 @@
h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
+ s_update(km0,iScalar,cell1) = s_update(km0,iScalar,cell1) - h_flux_upwind / grid % areaCell % array(cell1)
+ s_update(km0,iScalar,cell2) = s_update(km0,iScalar,cell2) + h_flux_upwind / grid % areaCell % array(cell2)
end do
end do
@@ -1627,8 +1560,8 @@
h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
+ s_update(km0,iScalar,cell1) = s_update(km0,iScalar,cell1) - h_flux_upwind / grid % areaCell % array(cell1)
+ s_update(km0,iScalar,cell2) = s_update(km0,iScalar,cell2) + h_flux_upwind / grid % areaCell % array(cell2)
end do
end do
@@ -1647,14 +1580,14 @@
s_max(iScalar) = max(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
s_min(iScalar) = min(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
- s_max_update(iScalar) = s_update(iScalar,iCell,km0)
- s_min_update(iScalar) = s_update(iScalar,iCell,km0)
+ s_max_update(iScalar) = s_update(km0,iScalar,iCell)
+ s_min_update(iScalar) = s_update(km0,iScalar,iCell)
! add in vertical flux to get max and min estimate
s_max_update(iScalar) = s_max_update(iScalar) &
- - rdnw(k) * (max(0.0_RKIND,v_flux(iScalar,iCell,km0)) - min(0.0_RKIND,v_flux(iScalar,iCell,km1)))
+ - rdnw(k) * (max(0.0_RKIND,v_flux(km0,iScalar,iCell)) - min(0.0_RKIND,v_flux(km1,iScalar,iCell)))
s_min_update(iScalar) = s_min_update(iScalar) &
- - rdnw(k) * (min(0.0_RKIND,v_flux(iScalar,iCell,km0)) - max(0.0_RKIND,v_flux(iScalar,iCell,km1)))
+ - rdnw(k) * (min(0.0_RKIND,v_flux(km0,iScalar,iCell)) - max(0.0_RKIND,v_flux(km1,iScalar,iCell)))
end do
@@ -1681,33 +1614,33 @@
if( config_positive_definite ) s_min(:) = 0.
do iScalar=1,num_scalars
- scale_out (iScalar,iCell,km0) = 1.
- scale_in (iScalar,iCell,km0) = 1.
+ scale_out (km0,iScalar,iCell) = 1.
+ scale_in (km0,iScalar,iCell) = 1.
s_max_update (iScalar) = s_max_update (iScalar) / h_new (k,iCell)
s_min_update (iScalar) = s_min_update (iScalar) / h_new (k,iCell)
- s_upwind = s_update(iScalar,iCell,km0) / h_new(k,iCell)
+ s_upwind = s_update(km0,iScalar,iCell) / h_new(k,iCell)
if ( s_max_update(iScalar) > s_max(iScalar) .and. config_monotonic) &
- scale_in (iScalar,iCell,km0) = max(0.0_RKIND,(s_max(iScalar)-s_upwind)/(s_max_update(iScalar)-s_upwind+eps))
+ scale_in (km0,iScalar,iCell) = max(0.0_RKIND,(s_max(iScalar)-s_upwind)/(s_max_update(iScalar)-s_upwind+eps))
if ( s_min_update(iScalar) < s_min(iScalar) ) &
- scale_out (iScalar,iCell,km0) = max(0.0_RKIND,(s_upwind-s_min(iScalar))/(s_upwind-s_min_update(iScalar)+eps))
+ scale_out (km0,iScalar,iCell) = max(0.0_RKIND,(s_upwind-s_min(iScalar))/(s_upwind-s_min_update(iScalar)+eps))
end do
end do ! end loop over cells to compute scale factor
- call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_out(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_out(:,:,2), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_in(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_in(:,:,2), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
+ tempField % block => block
+ tempField % dimSizes(1) = 2
+ tempField % dimSizes(2) = num_scalars
+ tempField % dimSizes(3) = grid % nCells
+ tempField % sendList => block % parinfo % cellsToSend
+ tempField % recvList => block % parinfo % cellsToRecv
+ tempField % array => scale_in
+ call mpas_dmpar_exch_halo_field(tempField)
+
+ tempField % array => scale_out
+ call mpas_dmpar_exch_halo_field(tempField)
+
! rescale the horizontal fluxes
do iEdge = 1, grid % nEdges
@@ -1716,9 +1649,9 @@
do iScalar=1,num_scalars
flux = h_flux(iScalar,iEdge)
if (flux > 0) then
- flux = flux * min(scale_out(iScalar,cell1,km0), scale_in(iScalar,cell2,km0))
+ flux = flux * min(scale_out(km0,iScalar,cell1), scale_in(km0,iScalar,cell2))
else
- flux = flux * min(scale_in(iScalar,cell1,km0), scale_out(iScalar,cell2,km0))
+ flux = flux * min(scale_in(km0,iScalar,cell1), scale_out(km0,iScalar,cell2))
end if
h_flux(iScalar,iEdge) = flux
end do
@@ -1728,13 +1661,13 @@
do iCell=1,grid % nCells
do iScalar=1,num_scalars
- flux = v_flux(iScalar,iCell,km1)
+ flux = v_flux(km1,iScalar,iCell)
if (flux > 0) then
- flux = flux * min(scale_out(iScalar,iCell,km0), scale_in(iScalar,iCell,km1))
+ flux = flux * min(scale_out(km0,iScalar,iCell), scale_in(km1,iScalar,iCell))
else
- flux = flux * min(scale_in(iScalar,iCell,km0), scale_out(iScalar,iCell,km1))
+ flux = flux * min(scale_in(km0,iScalar,iCell), scale_out(km1,iScalar,iCell))
end if
- v_flux(iScalar,iCell,km1) = flux
+ v_flux(km1,iScalar,iCell) = flux
end do
end do
@@ -1748,8 +1681,8 @@
do iCell=1,grid % nCells
! add in upper vertical flux that was just renormalized
do iScalar=1,num_scalars
- s_update(iScalar,iCell,km0) = s_update(iScalar,iCell,km0) + rdnw(k) * v_flux(iScalar,iCell,km1)
- if (k > 1) s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) - rdnw(k-1)*v_flux(iScalar,iCell,km1)
+ s_update(km0,iScalar,iCell) = s_update(km0,iScalar,iCell) + rdnw(k) * v_flux(km1,iScalar,iCell)
+ if (k > 1) s_update(km1,iScalar,iCell) = s_update(km1,iScalar,iCell) - rdnw(k-1)*v_flux(km1,iScalar,iCell)
end do
end do
@@ -1757,9 +1690,9 @@
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
do iScalar=1,num_scalars
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - &
+ s_update(km0,iScalar,cell1) = s_update(km0,iScalar,cell1) - &
h_flux(iScalar,iEdge) / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + &
+ s_update(km0,iScalar,cell2) = s_update(km0,iScalar,cell2) + &
h_flux(iScalar,iEdge) / grid % areaCell % array(cell2)
end do
end do
@@ -1768,13 +1701,13 @@
if (k > 1) then
do iCell=1,grid % nCells
do iScalar=1,num_scalars
- s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) / h_new(k-1,iCell)
+ s_update(km1,iScalar,iCell) = s_update(km1,iScalar,iCell) / h_new(k-1,iCell)
end do
end do
do iCell=1,grid % nCells
do iScalar=1,num_scalars
- scalar_new(iScalar,k-1,iCell) = s_update(iScalar,iCell,km1)
+ scalar_new(iScalar,k-1,iCell) = s_update(km1,iScalar,iCell)
end do
end do
end if
@@ -1787,7 +1720,7 @@
do iCell=1,grid % nCells
do iScalar=1,num_scalars
- scalar_new(iScalar,grid % nVertLevels,iCell) = s_update(iScalar,iCell,km1) / h_new(grid%nVertLevels,iCell)
+ scalar_new(iScalar,grid % nVertLevels,iCell) = s_update(km1,iScalar,iCell) / h_new(grid%nVertLevels,iCell)
end do
end do
Modified: trunk/mpas/src/core_init_nhyd_atmos/Registry
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/Registry 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_init_nhyd_atmos/Registry 2012-04-24 23:11:28 UTC (rev 1802)
@@ -28,8 +28,13 @@
namelist character io config_sfc_update_name sfc_update.nc
namelist character io config_output_name init.nc
namelist character io config_restart_name restart.nc
-namelist character io config_decomp_file_prefix graph.info.part.
namelist integer io config_frames_per_outfile 0
+namelist integer io config_pio_num_iotasks 0
+namelist integer io config_pio_stride 1
+namelist character decomposition config_block_decomp_file_prefix graph.info.part.
+namelist integer decomposition config_number_of_blocks 0
+namelist logical decomposition config_explicit_proc_decomp .false.
+namelist character decomposition config_proc_decomp_file_prefix graph.info.part.
namelist integer restart config_restart_interval 0
namelist logical restart config_do_restart false
namelist real restart config_restart_time 172800.0
Modified: trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -8,6 +8,7 @@
use mpas_atmphys_initialize_real
use mpas_RBF_interpolation
use mpas_vector_reconstruction
+ use mpas_timer
! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping
use mpas_timekeeping !, only: MPAS_Time_type, MPAS_TimeInterval_type, MPAS_Clock_type, &
@@ -35,7 +36,6 @@
type (block_type), pointer :: block_ptr
-
!
! Do some quick checks to make sure compile options are compatible with the chosen test case
!
@@ -103,8 +103,9 @@
write(0,*) ' real-data GFS test case '
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call init_atm_test_case_gfs(domain % dminfo, block_ptr % mesh, block_ptr % fg, block_ptr % state % time_levs(1) % state, &
- block_ptr % diag, config_test_case, block_ptr % parinfo)
+ call init_atm_test_case_gfs(block_ptr % mesh, block_ptr % fg, &
+ block_ptr % state % time_levs(1) % state, block_ptr % diag, &
+ config_test_case)
if (config_met_interp) call physics_initialize_real(block_ptr % mesh, block_ptr % fg)
block_ptr => block_ptr % next
end do
@@ -126,6 +127,7 @@
end if
+
block_ptr => domain % blocklist
do while (associated(block_ptr))
do i=2,nTimeLevs
@@ -144,7 +146,6 @@
end do
endif
-
end subroutine init_atm_setup_test_case
!----------------------------------------------------------------------------------------------------------
@@ -2153,7 +2154,7 @@
end subroutine init_atm_test_case_mtn_wave
- subroutine init_atm_test_case_gfs(dminfo, grid, fg, state, diag, test_case, parinfo)
+ subroutine init_atm_test_case_gfs(grid, fg, state, diag, test_case)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Real-data test case using GFS data
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -2165,13 +2166,15 @@
implicit none
- type (dm_info), intent(in) :: dminfo
type (mesh_type), intent(inout) :: grid
type (fg_type), intent(inout) :: fg
type (state_type), intent(inout) :: state
type (diag_type), intent(inout) :: diag
integer, intent(in) :: test_case
+
+ type (block_type), pointer :: block
type (parallel_info), pointer :: parinfo
+ type (dm_info), pointer :: dminfo
real (kind=RKIND), parameter :: u0 = 35.0
real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
@@ -2215,6 +2218,8 @@
real (kind=RKIND), dimension(:,:), pointer :: v
real (kind=RKIND), dimension(:,:), pointer :: sorted_arr
+ type (field1DReal):: tempField
+
real(kind=RKIND), dimension(:), pointer :: hs, hs1
real(kind=RKIND) :: hm, zh, dzmin, dzmina, dzmina_global, dzminf, sm
integer :: nsmterrain, kz, sfc_k
@@ -2273,6 +2278,11 @@
real (kind=RKIND) :: dlat
real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2
+
+ block => grid % block
+ parinfo => block % parinfo
+ dminfo => block % domain % dminfo
+
weightsOnEdge => grid % weightsOnEdge % array
nEdgesOnEdge => grid % nEdgesOnEdge % array
nEdgesOnCell => grid % nEdgesOnCell % array
@@ -2376,7 +2386,7 @@
allocate(rarray(nx,ny,nzz))
allocate(nhs(grid % nCells))
nhs(:) = 0
- grid % ter % array(:) = 0.0
+ ter(:) = 0.0
do jTileStart=1,20401,ny-6
! do jTileStart=1,961,ny-6
@@ -2409,7 +2419,7 @@
grid % nCells, grid % maxEdges, grid % nEdgesOnCell % array, grid % cellsOnCell % array, &
grid % latCell % array, grid % lonCell % array)
- grid % ter % array(iPoint) = grid % ter % array(iPoint) + rarray(i,j,1)
+ ter(iPoint) = ter(iPoint) + rarray(i,j,1)
nhs(iPoint) = nhs(iPoint) + 1
end do
@@ -2419,7 +2429,7 @@
end do
do iCell=1, grid % nCells
- grid % ter % array(iCell) = grid % ter % array(iCell) / real(nhs(iCell))
+ ter(iCell) = ter(iCell) / real(nhs(iCell))
end do
deallocate(rarray)
@@ -2980,7 +2990,7 @@
nInterpPoints = grid % nCells
latPoints => grid % latCell % array
lonPoints => grid % lonCell % array
- destField1d => grid % ter % array
+ destField1d => ter
ndims = 1
end if
@@ -3046,11 +3056,9 @@
ter(iCell) = hs(iCell) - 0.25*ter(iCell)
end do
- call mpas_dmpar_exch_halo_field1d_real(dminfo, ter(:), &
- grid % nCells, &
- parinfo % cellsToSend, parinfo % cellsToRecv)
+ ! note that ther variable ter used throughout this section is a pointer to grid % ter % array, here we are passing ter's parent field
+ call mpas_dmpar_exch_halo_field(grid % ter)
-
end do
do iCell=1,grid % nCells
@@ -3164,7 +3172,7 @@
sm = .05*min(0.5_RKIND*zw(k)/hm,1.0_RKIND)
do i=1,50
- do iCell=1,grid %nCells
+ do iCell=1,grid % nCells
hs1(iCell) = 0.
do j = 1,nEdgesOnCell(iCell)
@@ -3184,10 +3192,16 @@
end do
- call mpas_dmpar_exch_halo_field1d_real(dminfo, hs(:), &
- grid % nCells, &
- parinfo % cellsToSend, parinfo % cellsToRecv)
+ tempField % block => block
+ tempField % dimSizes(1) = grid % nCells
+ tempField % sendList => parinfo % cellsToSend
+ tempField % recvList => parinfo % cellsToRecv
+ tempField % array => hs
+ call mpas_timer_start("EXCHANGE_1D_REAL")
+ call mpas_dmpar_exch_halo_field(tempField)
+ call mpas_timer_stop("EXCHANGE_1D_REAL")
+
! dzmina = minval(hs(:)-hx(k-1,:))
dzmina = minval(zw(k)+ah(k)*hs(1:grid%nCellsSolve)-zw(k-1)-ah(k-1)*hx(k-1,1:grid%nCellsSolve))
call mpas_dmpar_min_real(dminfo, dzmina, dzmina_global)
Modified: trunk/mpas/src/core_nhyd_atmos/Registry
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/Registry 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_nhyd_atmos/Registry 2012-04-24 23:11:28 UTC (rev 1802)
@@ -44,7 +44,12 @@
namelist character io config_restart_name restart.nc
namelist character io config_output_interval 06:00:00
namelist integer io config_frames_per_outfile 0
-namelist character io config_decomp_file_prefix graph.info.part.
+namelist integer io config_pio_num_iotasks 0
+namelist integer io config_pio_stride 1
+namelist character decomposition config_block_decomp_file_prefix graph.info.part.
+namelist integer decomposition config_number_of_blocks 0
+namelist logical decomposition config_explicit_proc_decomp .false.
+namelist character decomposition config_proc_decomp_file_prefix graph.info.part.
namelist logical restart config_do_restart false
namelist logical restart config_do_DAcycling false
namelist character restart config_restart_interval none
@@ -316,10 +321,10 @@
namelist integer physics noznlev 59
namelist integer physics naerlev 29
-namelist integer physics cam_dim1 4
+namelist integer physics camdim1 4
dim nOznLevels namelist:noznlev
dim nAerLevels namelist:naerlev
-dim cam_dim1 namelist:cam_dim1
+dim cam_dim1 namelist:camdim1
%... DIMENSION NEEDED FOR LONGWAVE AND SHORTWAVE RADIATION FLUXES TO INCLUDE AN ADDITIONAL LAYER
%... BETWEEN THE TOP OF THE MODEL AND THE TOP OF THE ATMOSPHERE
Modified: trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -2,8 +2,8 @@
use mpas_framework
- type (io_output_object) :: restart_obj
- type (io_input_object) :: sfc_update_obj
+ type (io_output_object), save :: restart_obj
+ type (io_input_object), save :: sfc_update_obj
integer :: current_outfile_frames
type (MPAS_Clock_type) :: clock
@@ -34,6 +34,7 @@
type (MPAS_TimeInterval_type) :: timeDiff, minTimeDiff
character(len=32) :: timeStamp
integer :: i
+ integer :: ierr
if (.not. config_do_restart) call atm_setup_test_case(domain)
@@ -58,48 +59,17 @@
sfc_update_obj % filename = trim(config_sfc_update_name)
sfc_update_obj % stream = STREAM_SFC
- call mpas_io_input_init(sfc_update_obj, domain % dminfo)
+ call mpas_io_input_init(sfc_update_obj, domain % blocklist, domain % dminfo)
!
! We need to decide which time slice to read from the surface file - read the most recent time slice that falls before or on the start time
!
- sfc_update_obj % time = 1
-
- if (sfc_update_obj % rdLocalTime <= 0) then
- write(0,*) 'Error: Couldn''t find any times in surface update file.'
+ sfc_update_obj % time = MPAS_seekStream(sfc_update_obj % io_stream, trim(config_start_time), MPAS_STREAM_LATEST_BEFORE, timeStamp, ierr)
+ if (ierr == MPAS_IO_ERR) then
+ write(0,*) 'Error: surface update file '//trim(sfc_update_obj % filename)//' did not contain any times at or before '//trim(config_start_time)
call mpas_dmpar_abort(domain % dminfo)
end if
-
- if (domain % dminfo % my_proc_id == IO_NODE) then
- allocate(xtime % ioinfo)
- xtime % ioinfo % start(1) = 1
- xtime % ioinfo % count(1) = sfc_update_obj % rdLocalTime
- allocate(xtime % array(sfc_update_obj % rdLocalTime))
- xtime % ioinfo % fieldName = 'xtime'
- call mpas_io_input_field(sfc_update_obj, xtime)
-
- call mpas_set_timeInterval(interval=minTimeDiff, DD=10000)
- call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time)
-
- do i=1,sfc_update_obj % rdLocalTime
- call mpas_set_time(curr_time=sliceTime, dateTimeString=xtime % array(i))
- timeDiff = abs(sliceTime - startTime)
- if (sliceTime <= startTime .and. timeDiff < minTimeDiff) then
- minTimeDiff = timeDiff
- sfc_update_obj % time = i
- end if
- end do
-
- timeStamp = xtime % array(sfc_update_obj % time)
-
- deallocate(xtime % ioinfo)
- deallocate(xtime % array)
- end if
-
- call mpas_dmpar_bcast_int(domain % dminfo, sfc_update_obj % time)
- call mpas_dmpar_bcast_char(domain % dminfo, timeStamp)
-
write(0,*) 'Starting model with surface time ', timeStamp
end if
@@ -190,25 +160,19 @@
type (mesh_type), intent(inout) :: mesh
real (kind=RKIND), intent(in) :: dt
- call mpas_dmpar_exch_halo_field2d_real(dminfo, block % state % time_levs(1) % state % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field(block % state % time_levs(1) % state % u)
if (.not. config_do_restart .or. (config_do_restart .and. config_do_DAcycling)) then
call atm_init_coupled_diagnostics( block % state % time_levs(1) % state, block % diag, mesh)
end if
call atm_compute_solve_diagnostics(dt, block % state % time_levs(1) % state, block % diag, mesh)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, block % diag % pv_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, block % diag % ru % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, block % diag % rw % array, &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % CellsToSend, block % parinfo % CellsToRecv)
+ call mpas_dmpar_exch_halo_field(block % diag % pv_edge)
+ call mpas_dmpar_exch_halo_field(block % diag % ru)
+
+ call mpas_dmpar_exch_halo_field(block % diag % rw)
+
call mpas_rbf_interp_initialize(mesh)
call mpas_init_reconstruct(mesh)
call mpas_reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
@@ -298,11 +262,7 @@
if (mpas_is_alarm_ringing(clock, sfcAlarmID, ierr=ierr)) then
call mpas_reset_clock_alarm(clock, sfcAlarmID, ierr=ierr)
- call mpas_read_and_distribute_fields(domain % dminfo, sfc_update_obj, domain % blocklist, &
- readCellStart, nReadCells, readEdgeStart, nReadEdges, readVertexStart, nReadVertices, &
- readVertLevelStart, nReadVertLevels, &
- sendCellList, recvCellList, sendEdgeList, recvEdgeList, sendVertexList, recvVertexList, &
- sendVertLevelList, recvVertLevelList)
+ call mpas_read_and_distribute_fields(sfc_update_obj)
sfc_update_obj % time = sfc_update_obj % time + 1
end if
Modified: trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -98,6 +98,7 @@
real (kind=RKIND) :: domain_mass, scalar_mass, scalar_min, scalar_max
real (kind=RKIND) :: global_domain_mass, global_scalar_mass, global_scalar_min, global_scalar_max
+
!
! Initialize RK weights
!
@@ -122,30 +123,22 @@
! the so-called owned edges?
- block => domain % blocklist
- do while (associated(block))
! WCS-parallel: first three and rtheta_p arise from scalar transport and microphysics update (OK). Others come from where?
! theta_m
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(1) % state % theta_m % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(1) % state % theta_m)
+
! scalars
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % state % time_levs(1) % state % scalars % array(:,:,:), &
- block % state % time_levs(1) % state % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(1) % state % scalars)
+
! pressure_p
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % pressure_p % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % pressure_p)
+
! rtheta_p
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % rtheta_p % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rtheta_p)
+
block => domain % blocklist
do while (associated(block))
! We are setting values in the halo here, so no communications are needed.
@@ -185,9 +178,12 @@
if (debug) write(0,*) ' add physics tendencies '
block => domain % blocklist
do while (associated(block))
- call physics_addtend( domain % dminfo , block % parinfo % cellsToSend, block % parinfo % cellsToRecv, &
- block % mesh , block % state % time_levs(1) % state, block % diag, block % tend, &
- block % tend_physics , block % state % time_levs(2) % state % rho_zz % array(:,:), &
+ call physics_addtend( block % mesh, &
+ block % state % time_levs(1) % state, &
+ block % diag, &
+ block % tend, &
+ block % tend_physics, &
+ block % state % time_levs(2) % state % rho_zz % array(:,:), &
block % diag % rho_edge % array(:,:) )
block => block % next
end do
@@ -199,19 +195,13 @@
! because we are solving for all edges of owned cells
!***********************************
- block => domain % blocklist
- do while (associated(block))
! tend_u
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % u, (/ 1 /))
block => domain % blocklist
do while (associated(block))
call atm_set_smlstep_pert_variables( block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
- block % tend, block % diag, block % mesh )
+ block % tend, block % diag, block % mesh )
call atm_compute_vert_imp_coefs( block % state % time_levs(2) % state, block % mesh, block % diag, rk_sub_timestep(rk_step) )
block => block % next
end do
@@ -223,7 +213,7 @@
block => domain % blocklist
do while (associated(block))
call atm_advance_acoustic_step( block % state % time_levs(2) % state, block % diag, block % tend, &
- block % mesh, rk_sub_timestep(rk_step) )
+ block % mesh, rk_sub_timestep(rk_step) )
block => block % next
end do
@@ -233,20 +223,12 @@
! WCS-parallel: is this a candidate for a smaller stencil? we need only communicate cells that share edges with owned cells.
- block => domain % blocklist
- do while (associated(block))
! rtheta_pp
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % rtheta_pp % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rtheta_pp, (/ 1 /))
end do ! end of small stimestep loop
! will need communications here for rho_pp
- block => domain % blocklist
- do while (associated(block))
! WCS-parallel: is communication of rw_p and rho_pp because of limiter (pd or mono scheme?),
! or is it needed for the large-step variable recovery (to get decoupled variables)?
@@ -258,43 +240,36 @@
! MGD seems necessary
! rw_p
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % rw_p % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /))
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rw_p)
+
! MGD seems necessary
! ru_p
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % ru_p % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % ru_p, (/ 2 /))
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % ru_p)
+
! rho_pp
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % rho_pp % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rho_pp)
+ ! the second layer of halo cells must be exchanged before calling atm_recover_large_step_variables
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rtheta_pp, (/ 2 /))
+
+
block => domain % blocklist
do while (associated(block))
- call atm_recover_large_step_variables( block % state % time_levs(2) % state, &
+ call atm_recover_large_step_variables( block % state % time_levs(2) % state, &
block % diag, block % tend, block % mesh, &
rk_timestep(rk_step), number_sub_steps(rk_step), rk_step )
-
block => block % next
end do
! ************ advection of moist variables here...
- block => domain % blocklist
- do while (associated(block))
! u
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- block => block % next
- end do
+ !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % state % time_levs(2) % state % u, (/ 3 /))
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
-
if (config_scalar_advection) then
block => domain % blocklist
@@ -305,16 +280,16 @@
! so we keep the advance_scalars routine as well
!
if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then
- call atm_advance_scalars( block % tend, &
+ call atm_advance_scalars( block % tend, &
block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
block % diag, &
block % mesh, rk_timestep(rk_step) )
else
- call atm_advance_scalars_mono( block % tend, &
- block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
- block % diag, &
- block % mesh, rk_timestep(rk_step), rk_step, 3, &
- domain % dminfo, block % parinfo % cellsToSend, block % parinfo % cellsToRecv )
+ block % domain = domain
+ call atm_advance_scalars_mono( block % tend, &
+ block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
+ block % diag, block % mesh, &
+ rk_timestep(rk_step), rk_step, 3 )
end if
block => block % next
end do
@@ -354,33 +329,25 @@
! need communications here to fill out u, w, theta_m, p, and pp, scalars, etc
! so that they are available for next RK step or the first rk substep of the next timestep
- block => domain % blocklist
- do while (associated(block))
!MGD seems necessary
! w
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % w % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % w)
+
! pv_edge
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % pv_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % pv_edge)
+
! rho_edge
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % rho_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rho_edge)
! **** this will always be needed - perhaps we can cover this with compute_solve_diagnostics
! scalars
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % state % time_levs(2) % state % scalars % array(:,:,:), &
- block % state % time_levs(2) % state % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ if(rk_step < 3) then
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % scalars)
+ end if
- end do ! rk_step loop
+ end do ! rk_step loop
!... compute full velocity vectors at cell centers:
block => domain % blocklist
@@ -1434,7 +1401,7 @@
!---------------------------
- subroutine atm_advance_scalars_mono( tend, s_old, s_new, diag, grid, dt, rk_step, rk_order, dminfo, cellsToSend, cellsToRecv)
+ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt, rk_step, rk_order)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Input: s - current model state
@@ -1442,23 +1409,20 @@
!
implicit none
- type (tend_type), intent(in) :: tend
- type (state_type), intent(in) :: s_old
- type (state_type), intent(inout) :: s_new
- type (diag_type), intent(in) :: diag
- type (mesh_type), intent(in) :: grid
- real (kind=RKIND) :: dt
+ type (tend_type),intent(in) :: tend
+ type (state_type),intent(inout) :: s_old
+ type (state_type),intent(inout) :: s_new
+ type (diag_type),intent(in) :: diag
+ type (mesh_type),intent(in) :: grid
+ real (kind=RKIND),intent(in) :: dt
+ integer, intent(in) :: rk_step, rk_order
- integer, intent(in) :: rk_step, rk_order
- type (dm_info), intent(in) :: dminfo
- type (exchange_list), pointer :: cellsToSend, cellsToRecv
-
-
+ type (block_type), pointer :: block
integer :: i, iCell, iEdge, k, iScalar, cell1, cell2
real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2, scalar_weight
real (kind=RKIND) :: scalar_weight_cell1, scalar_weight_cell2
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old_in, scalar_new_in, scalar_tend
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar_tend
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg, rho_edge, rho_zz, zgrid, kdiff
real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell, qv_init
@@ -1468,9 +1432,11 @@
integer, dimension(:), pointer :: nAdvCellsForEdge
real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd
+ type (field2DReal) :: tempField
+
real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: scalar_old, scalar_new
real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: s_max, s_min, s_update
- real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: scale_in, scale_out
+ real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ), target :: scale_in, scale_out
real (kind=RKIND), dimension( grid % nVertLevels, grid % nEdges ) :: flux_arr
real (kind=RKIND), dimension( grid % nVertLevels + 1, grid % nCells ) :: wdtn
@@ -1497,10 +1463,10 @@
flux4(q_im2, q_im1, q_i, q_ip1, ua) + &
coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
+ block => grid % block
+
coef_3rd_order = config_coef_3rd_order
- scalar_old_in => s_old % scalars % array
- scalar_new_in => s_new % scalars % array
kdiff => diag % kdiff % array
deriv_two => grid % deriv_two % array
uhAvg => diag % ruAvg % array
@@ -1545,7 +1511,7 @@
do iCell = 1,grid%nCellsSolve
do k = 1, grid%nVertLevels
do iScalar = 1,s_old%num_scalars
- scalar_old_in(iScalar,k,iCell) = scalar_old_in(iScalar,k,iCell)+dt*scalar_tend(iScalar,k,iCell) / h_old(k,iCell)
+ s_old % scalars % array(iScalar,k,iCell) = s_old % scalars % array(iScalar,k,iCell)+dt*scalar_tend(iScalar,k,iCell) / h_old(k,iCell)
scalar_tend(iScalar,k,iCell) = 0.
end do
end do
@@ -1553,12 +1519,7 @@
! halo exchange
- call mpas_dmpar_exch_halo_field3d_real( dminfo, &
- scalar_old_in(:,:,:), &
- s_old % num_scalars, &
- grid % nVertLevels, &
- grid % nCells, &
- cellsToSend, cellsToRecv )
+ call mpas_dmpar_exch_halo_field(s_old % scalars)
!
! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old
@@ -1573,8 +1534,8 @@
do iCell = 1, grid%nCells
do k=1, grid%nVertLevels
- scalar_old(k,iCell) = scalar_old_in(iScalar,k,iCell)
- scalar_new(k,iCell) = scalar_new_in(iScalar,k,iCell)
+ scalar_old(k,iCell) = s_old % scalars % array(iScalar,k,iCell)
+ scalar_new(k,iCell) = s_new % scalars % array(iScalar,k,iCell)
end do
end do
@@ -1734,17 +1695,23 @@
!
! communicate scale factors here
!
- call mpas_dmpar_exch_halo_field2d_real( dminfo, &
- scale_in(:,:), &
- grid % nVertLevels, &
- grid % nCells, &
- cellsToSend, cellsToRecv )
- call mpas_dmpar_exch_halo_field2d_real( dminfo, &
- scale_out(:,:), &
- grid % nVertLevels, &
- grid % nCells, &
- cellsToSend, cellsToRecv )
!
+! WCS_halo_opt_2 - communicate only first halo row in these next two exchanges
+!
+
+ tempField % block => block
+ tempField % dimSizes(1) = grid % nVertLevels
+ tempField % dimSizes(2) = grid % nCells
+ tempField % sendList => block % parinfo % cellsToSend
+ tempField % recvList => block % parinfo % cellsToRecv
+
+ tempField % array => scale_in
+ call mpas_dmpar_exch_halo_field(tempField, (/ 1 /))
+
+ tempField % array => scale_out
+ call mpas_dmpar_exch_halo_field(tempField, (/ 1 /))
+
+!
! rescale the fluxes
!
do iEdge = 1, grid % nEdges
@@ -1814,7 +1781,7 @@
do iCell = 1, grid%nCells
do k=1, grid%nVertLevels
- scalar_new_in(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell))
+ s_new % scalars % array(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell))
end do
end do
Modified: trunk/mpas/src/core_ocean/Registry
===================================================================
--- trunk/mpas/src/core_ocean/Registry 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_ocean/Registry 2012-04-24 23:11:28 UTC (rev 1802)
@@ -18,7 +18,12 @@
namelist character io config_restart_name restart.nc
namelist character io config_output_interval 24:00:00
namelist integer io config_frames_per_outfile 0
-namelist character io config_decomp_file_prefix graph.info.part.
+namelist integer io config_pio_num_iotasks 0
+namelist integer io config_pio_stride 1
+namelist character decomposition config_block_decomp_file_prefix graph.info.part.
+namelist integer decomposition config_number_of_blocks 0
+namelist logical decomposition config_explicit_proc_decomp .false.
+namelist character decomposition config_proc_decomp_file_prefix graph.info.part.
namelist logical restart config_do_restart false
namelist character restart config_restart_interval none
namelist character grid config_vert_grid_type isopycnal
Modified: trunk/mpas/src/core_ocean/mpas_ocn_global_diagnostics.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_global_diagnostics.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_ocean/mpas_ocn_global_diagnostics.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -46,13 +46,15 @@
real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal, localCFL, localSum, areaCellGlobal, areaEdgeGlobal, areaTriangleGlobal
real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, areaTriangle, areaEdge
- real (kind=RKIND), dimension(:,:), pointer :: h, u, v, h_edge, circulation, vorticity, ke, Vor_edge, Vor_vertex, &
+ real (kind=RKIND), dimension(:,:), pointer :: h, u, v, h_edge, vorticity, ke, Vor_edge, Vor_vertex, &
Vor_cell, gradVor_n, gradVor_t, pressure, MontPot, wTop, rho, tracerTemp
real (kind=RKIND), dimension(:,:,:), pointer :: tracers
real (kind=RKIND), dimension(kMaxVariables) :: sums, mins, maxes, averages, verticalSumMins, verticalSumMaxes, reductions
real (kind=RKIND), dimension(kMaxVariables) :: sums_tmp, mins_tmp, maxes_tmp, averages_tmp, verticalSumMins_tmp, verticalSumMaxes_tmp
+ real (kind=RKIND), dimension(:,:), allocatable :: enstrophy
+
block => domain % blocklist
dminfo => domain % dminfo
@@ -90,7 +92,6 @@
v => state % v % array
wTop => state % wTop % array
h_edge => state % h_edge % array
- circulation => state % circulation % array
vorticity => state % vorticity % array
ke => state % ke % array
Vor_edge => state % Vor_edge % array
@@ -144,9 +145,9 @@
verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! circulation
+ ! vorticity
variableIndex = variableIndex + 1
- call ocn_compute_field_local_stats(dminfo, nVertLevels, nVerticesSolve, circulation(:,1:nVerticesSolve), &
+ call ocn_compute_field_local_stats(dminfo, nVertLevels, nVerticesSolve, vorticity(:,1:nVerticesSolve), &
sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex))
sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
@@ -154,11 +155,14 @@
verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! vorticity
+ ! vorticity**2
+ allocate(enstrophy(nVertLevels,nVerticesSolve))
+ enstrophy(:,:)=vorticity(:,1:nVerticesSolve)**2
variableIndex = variableIndex + 1
call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nVerticesSolve, areaTriangle(1:nVerticesSolve), &
- vorticity(:,1:nVerticesSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), &
+ enstrophy(:,:), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), &
verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex))
+ deallocate(enstrophy)
sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
@@ -362,7 +366,7 @@
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/(areaEdgeGlobal*nVertLevels)
- ! circulation
+ ! vorticity
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/(nVerticesGlobal*nVertLevels)
Modified: trunk/mpas/src/core_ocean/mpas_ocn_mpas_core.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_mpas_core.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_ocean/mpas_ocn_mpas_core.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -28,7 +28,7 @@
use ocn_time_average
- type (io_output_object) :: restart_obj
+ type (io_output_object), save :: restart_obj
integer :: current_outfile_frames
Modified: trunk/mpas/src/core_ocean/mpas_ocn_time_integration_rk4.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_time_integration_rk4.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_ocean/mpas_ocn_time_integration_rk4.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -78,7 +78,8 @@
integer :: iCell, k, i, err
type (block_type), pointer :: block
- type (state_type) :: provis
+ type (state_type), target :: provis
+ type (state_type), pointer :: provis_ptr
integer :: rk_step, iEdge, cell1, cell2
@@ -96,10 +97,13 @@
block => domain % blocklist
- call mpas_allocate_state(provis, &
+ call mpas_allocate_state(block, provis, &
block % mesh % nCells, block % mesh % nEdges, block % mesh % maxEdges, block % mesh % maxEdges2, &
block % mesh % nVertices, block % mesh % vertexDegree, block % mesh % nVertLevels )
+ provis_ptr => provis
+ call mpas_create_state_links(provis_ptr)
+
!
! Initialize time_levs(2) with state at current time
! Initialize first RK state
@@ -142,23 +146,11 @@
! --- update halos for diagnostic variables
call mpas_timer_start("RK4-diagnostic halo update")
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % Vor_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- if (config_h_mom_eddy_visc4 > 0.0) then
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % divergence % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % vorticity % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nVertices, &
- block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
- end if
-
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(provis % Vor_edge)
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call mpas_dmpar_exch_halo_field(provis % divergence)
+ call mpas_dmpar_exch_halo_field(provis % vorticity)
+ end if
call mpas_timer_stop("RK4-diagnostic halo update")
! --- compute tendencies
@@ -190,19 +182,9 @@
! --- update halos for prognostic variables
call mpas_timer_start("RK4-pronostic halo update")
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % tracers % array(:,:,:), &
- block % tend % num_tracers, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % u)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % h)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % tracers)
call mpas_timer_stop("RK4-pronostic halo update")
! --- compute next substep state
Modified: trunk/mpas/src/core_ocean/mpas_ocn_time_integration_split.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_time_integration_split.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_ocean/mpas_ocn_time_integration_split.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -163,27 +163,11 @@
! --- update halos for diagnostic variables
call mpas_timer_start("se halo diag", .false., timer_halo_diagnostic)
- block => domain % blocklist
- do while (associated(block))
-
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, &
- block % state % time_levs(2) % state % Vor_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- if (config_h_mom_eddy_visc4 > 0.0) then
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, &
- block % state % time_levs(2) % state % divergence % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, &
- block % state % time_levs(2) % state % vorticity % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nVertices, &
- block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
- end if
-
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % Vor_edge)
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % divergence)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % vorticity)
+ end if
call mpas_timer_stop("se halo diag", timer_halo_diagnostic)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -272,15 +256,7 @@
end do
call mpas_timer_start("se halo ubcl", .false., timer_halo_ubcl)
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, &
- block % state % time_levs(2) % state % uBcl % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % uBcl)
call mpas_timer_stop("se halo ubcl", timer_halo_ubcl)
end do ! do j=1,config_n_bcl_iter
@@ -406,15 +382,7 @@
! boundary update on uBtrNew
call mpas_timer_start("se halo ubtr", .false., timer_halo_ubtr)
- block => domain % blocklist
- do while (associated(block))
-
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:), &
- block % mesh % nEdges, block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- block => block % next
- end do ! block
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle)
call mpas_timer_stop("se halo ubtr", timer_halo_ubtr)
endif ! config_btr_gam1_uWt1>1.0e-12
@@ -473,15 +441,7 @@
! boundary update on SSHnew
call mpas_timer_start("se halo ssh", .false., timer_halo_ssh)
- block => domain % blocklist
- do while (associated(block))
-
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
- block % mesh % nCells, block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-
- block => block % next
- end do ! block
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle)
call mpas_timer_stop("se halo ssh", timer_halo_ssh)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -524,14 +484,7 @@
! boundary update on uBtrNew
call mpas_timer_start("se halo ubtr", .false., timer_halo_ubtr)
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:), &
- block % mesh % nEdges, block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- block => block % next
- end do ! block
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle)
call mpas_timer_stop("se halo ubtr", timer_halo_ubtr)
end do !do BtrCorIter=1,config_n_btr_cor_iter
@@ -584,15 +537,8 @@
! boundary update on SSHnew
call mpas_timer_start("se halo ssh", .false., timer_halo_ssh)
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
- block % mesh % nCells, block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-
- block => block % next
- end do ! block
- call mpas_timer_stop("se halo ssh", timer_halo_ssh)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle)
+ call mpas_timer_stop("se halo ssh", timer_halo_ssh)
endif ! config_btr_solve_SSH2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -643,14 +589,7 @@
! boundary update on F
call mpas_timer_start("se halo F", .false., timer_halo_f)
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(1) % state % FBtr % array(:), &
- block % mesh % nEdges, block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- block => block % next
- end do ! block
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(1) % state % FBtr)
call mpas_timer_stop("se halo F", timer_halo_f)
@@ -744,13 +683,7 @@
! update halo for thickness and tracer tendencies
call mpas_timer_start("se halo h", .false., timer_halo_h)
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % h)
call mpas_timer_stop("se halo h", timer_halo_h)
block => domain % blocklist
@@ -762,13 +695,7 @@
! update halo for thickness and tracer tendencies
call mpas_timer_start("se halo tracers", .false., timer_halo_tracers)
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % tracers % array(:,:,:), &
- block % tend % num_tracers, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % tracers)
call mpas_timer_stop("se halo tracers", timer_halo_tracers)
block => domain % blocklist
Modified: trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del4.F
===================================================================
--- trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -175,7 +175,7 @@
do k=1,maxLevelEdgeTop(iEdge)
! Compute </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="red">abla vorticity
delsq_u = ( divergence(k,cell2) - divergence(k,cell1) ) * invDcEdge &
- -viscVortCoef *( vorticity(k,vertex2) - vorticity(k,vertex1)) * invDvEdge
+ -viscVortCoef *( vorticity(k,vertex2) - vorticity(k,vertex1)) * invDcEdge * sqrt(3.0) ! TDR
! vorticity using </font>
<font color="gray">abla^2 u
r_tmp = dcEdge(iEdge) * delsq_u
@@ -203,7 +203,7 @@
do k=1,maxLevelEdgeTop(iEdge)
u_diffusion = (delsq_divergence(k,cell2) - delsq_divergence(k,cell1)) * invDcEdge &
- -viscVortCoef * (delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * invDvEdge
+ -viscVortCoef * (delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * invDcEdge * sqrt(3.0) ! TDR
tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * u_diffusion * r_tmp
end do
Modified: trunk/mpas/src/core_sw/Registry
===================================================================
--- trunk/mpas/src/core_sw/Registry 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_sw/Registry 2012-04-24 23:11:28 UTC (rev 1802)
@@ -26,7 +26,12 @@
namelist character io config_restart_name restart.nc
namelist character io config_output_interval 06:00:00
namelist integer io config_frames_per_outfile 0
-namelist character io config_decomp_file_prefix graph.info.part.
+namelist integer io config_pio_num_iotasks 0
+namelist integer io config_pio_stride 1
+namelist character decomposition config_block_decomp_file_prefix graph.info.part.
+namelist integer decomposition config_number_of_blocks 0
+namelist logical decomposition config_explicit_proc_decomp .false.
+namelist character decomposition config_proc_decomp_file_prefix graph.info.part.
namelist logical restart config_do_restart false
namelist character restart config_restart_interval none
Modified: trunk/mpas/src/core_sw/mpas_sw_mpas_core.F
===================================================================
--- trunk/mpas/src/core_sw/mpas_sw_mpas_core.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_sw/mpas_sw_mpas_core.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -3,7 +3,7 @@
use mpas_framework
use mpas_timekeeping
- type (io_output_object) :: restart_obj
+ type (io_output_object), save :: restart_obj
integer :: current_outfile_frames
type (MPAS_Clock_type) :: clock
Modified: trunk/mpas/src/core_sw/mpas_sw_time_integration.F
===================================================================
--- trunk/mpas/src/core_sw/mpas_sw_time_integration.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/core_sw/mpas_sw_time_integration.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -63,17 +63,21 @@
integer :: iCell, k
type (block_type), pointer :: block
- type (state_type) :: provis
+ type (state_type), target :: provis
+ type (state_type), pointer :: provis_ptr
integer :: rk_step
real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights
block => domain % blocklist
- call mpas_allocate_state(provis, &
+ call mpas_allocate_state(block, provis, &
block % mesh % nCells, block % mesh % nEdges, block % mesh % maxEdges, block % mesh % maxEdges2, &
block % mesh % nVertices, block % mesh % vertexDegree, block % mesh % nVertLevels, &
block % mesh % nTracers)
+
+ provis_ptr => provis
+ call mpas_create_state_links(provis_ptr)
!
! Initialize time_levs(2) with state at current time
@@ -116,24 +120,13 @@
! --- update halos for diagnostic variables
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % pv_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field(provis % pv_edge)
- if (config_h_mom_eddy_visc4 > 0.0) then
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % divergence % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % vorticity % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nVertices, &
- block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
- end if
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call mpas_dmpar_exch_halo_field(provis % divergence)
+ call mpas_dmpar_exch_halo_field(provis % vorticity)
+ end if
- block => block % next
- end do
-
! --- compute tendencies
block => domain % blocklist
@@ -146,19 +139,9 @@
! --- update halos for prognostic variables
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % tracers % array(:,:,:), &
- block % mesh % nTracers, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % u)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % h)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % tend % tracers)
! --- compute next substep state
Modified: trunk/mpas/src/driver/mpas_subdriver.F
===================================================================
--- trunk/mpas/src/driver/mpas_subdriver.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/driver/mpas_subdriver.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -5,7 +5,7 @@
type (dm_info), pointer :: dminfo
type (domain_type), pointer :: domain
- type (io_output_object) :: output_obj
+ type (io_output_object), save :: output_obj
integer :: output_frame
Modified: trunk/mpas/src/framework/Makefile
===================================================================
--- trunk/mpas/src/framework/Makefile 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/framework/Makefile 2012-04-24 23:11:28 UTC (rev 1802)
@@ -10,11 +10,15 @@
mpas_timekeeping.o \
mpas_configure.o \
mpas_constants.o \
+ mpas_dmpar_types.o \
+ mpas_attlist.o \
mpas_grid_types.o \
mpas_hash.o \
mpas_sort.o \
mpas_block_decomp.o \
mpas_dmpar.o \
+ mpas_io.o \
+ mpas_io_streams.o \
mpas_io_input.o \
mpas_io_output.o \
$(ZOLTANOBJ) \
@@ -25,16 +29,20 @@
framework: $(OBJS)
ar -ru libframework.a $(OBJS)
-mpas_framework.o: mpas_dmpar.o mpas_io_input.o mpas_io_output.o mpas_grid_types.o mpas_configure.o mpas_timer.o
+mpas_framework.o: mpas_dmpar.o mpas_io_input.o mpas_io_output.o mpas_io.o mpas_grid_types.o mpas_configure.o mpas_timer.o
mpas_configure.o: mpas_dmpar.o
mpas_constants.o: mpas_kind_types.o
-mpas_grid_types.o: mpas_dmpar.o
+mpas_dmpar_types.o : mpas_kind_types.o
-mpas_dmpar.o: mpas_sort.o streams.o mpas_kind_types.o
+mpas_attlist.o: mpas_kind_types.o
+mpas_grid_types.o: mpas_kind_types.o mpas_dmpar_types.o mpas_attlist.o
+
+mpas_dmpar.o: mpas_sort.o streams.o mpas_kind_types.o mpas_grid_types.o
+
mpas_sort.o: mpas_kind_types.o
mpas_timekeeping.o: mpas_kind_types.o
@@ -43,10 +51,14 @@
mpas_block_decomp.o: mpas_grid_types.o mpas_hash.o mpas_configure.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 $(ZOLTANOBJ)
+mpas_io.o: mpas_dmpar_types.o
-mpas_io_output.o: mpas_grid_types.o mpas_dmpar.o mpas_sort.o mpas_configure.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_output.o: mpas_grid_types.o mpas_dmpar.o mpas_sort.o mpas_configure.o mpas_io_streams.o
+
clean:
$(RM) *.o *.mod *.f90 libframework.a
Added: trunk/mpas/src/framework/add_field_indices.inc
===================================================================
--- trunk/mpas/src/framework/add_field_indices.inc (rev 0)
+++ trunk/mpas/src/framework/add_field_indices.inc 2012-04-24 23:11:28 UTC (rev 1802)
@@ -0,0 +1,48 @@
+ idim = ndims
+ totalDimSize = 0
+ field_ptr => field
+ if (trim(field % dimNames(idim)) == 'nCells') then
+!write(0,*) '... outer dimension is nCells'
+ allocate(indices(0))
+ do while (associated(field_ptr))
+ call mergeArrays(indices, field_ptr % block % mesh % indexToCellID % array(1:field_ptr % block % mesh % nCellsSolve))
+ totalDimSize = totalDimSize + field_ptr % block % mesh % nCellsSolve
+ field_ptr => field_ptr % next
+ end do
+ call mpas_dmpar_sum_int(field % block % domain % dminfo, totalDimSize, globalDimSize)
+ isDecomposed = .true.
+ else if (trim(field % dimNames(idim)) == 'nEdges') then
+!write(0,*) '... outer dimension is nEdges'
+ allocate(indices(0))
+ do while (associated(field_ptr))
+ call mergeArrays(indices, field_ptr % block % mesh % indexToEdgeID % array(1:field_ptr % block % mesh % nEdgesSolve))
+ totalDimSize = totalDimSize + field_ptr % block % mesh % nEdgesSolve
+ field_ptr => field_ptr % next
+ end do
+ call mpas_dmpar_sum_int(field % block % domain % dminfo, totalDimSize, globalDimSize)
+ isDecomposed = .true.
+ else if (trim(field % dimNames(idim)) == 'nVertices') then
+!write(0,*) '... outer dimension is nVertices'
+ allocate(indices(0))
+ do while (associated(field_ptr))
+ call mergeArrays(indices, field_ptr % block % mesh % indexToVertexID % array(1:field_ptr % block % mesh % nVerticesSolve))
+ totalDimSize = totalDimSize + field_ptr % block % mesh % nVerticesSolve
+ field_ptr => field_ptr % next
+ end do
+ call mpas_dmpar_sum_int(field % block % domain % dminfo, totalDimSize, globalDimSize)
+ isDecomposed = .true.
+ else
+ isDecomposed = .false.
+ globalDimSize = field % dimSizes(idim)
+ totalDimSize = globalDimSize
+
+ if (field % block % domain % dminfo % my_proc_id == IO_NODE) then
+ ndims = 1
+ allocate(indices(field % dimSizes(ndims)))
+ do i=1,field % dimSizes(ndims)
+ indices(i) = i
+ end do
+ else
+ allocate(indices(0))
+ end if
+ end if
Added: trunk/mpas/src/framework/mpas_attlist.F
===================================================================
--- trunk/mpas/src/framework/mpas_attlist.F (rev 0)
+++ trunk/mpas/src/framework/mpas_attlist.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -0,0 +1,441 @@
+module mpas_attlist
+
+ use mpas_kind_types
+
+ ! Derived type for holding field attributes
+ type att_list_type
+ character (len=64) :: attName
+ integer :: attType
+ integer :: attValueInt
+ integer, dimension(:), pointer :: attValueIntA => null()
+ real (kind=RKIND) :: attValueReal
+ real (kind=RKIND), dimension(:), pointer :: attValueRealA => null()
+ character (len=1024) :: attValueText
+ type (att_list_type), pointer :: next => null()
+ end type att_list_type
+
+ interface mpas_add_att
+ module procedure mpas_add_att_int0d
+ module procedure mpas_add_att_int1d
+ module procedure mpas_add_att_real0d
+ module procedure mpas_add_att_real1d
+ module procedure mpas_add_att_text
+ end interface mpas_add_att
+
+ interface mpas_get_att
+ module procedure mpas_get_att_int0d
+ module procedure mpas_get_att_int1d
+ module procedure mpas_get_att_real0d
+ module procedure mpas_get_att_real1d
+ module procedure mpas_get_att_text
+ end interface mpas_get_att
+
+
+ !!!!! PRIVATE? !!!!!
+
+ integer, parameter :: ATT_INT = 1
+ integer, parameter :: ATT_INTA = 2
+ integer, parameter :: ATT_REAL = 3
+ integer, parameter :: ATT_REALA = 4
+ integer, parameter :: ATT_TEXT = 5
+
+
+contains
+
+
+ subroutine mpas_add_att_int0d(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ integer, intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ if (.not. associated(attList)) then
+ allocate(attList)
+ cursor => attList
+ else
+ cursor => attList
+ do while (associated(cursor % next))
+ cursor => cursor % next
+ end do
+ allocate(cursor % next)
+ cursor => cursor % next
+ end if
+
+ cursor % attType = ATT_INT
+ write(cursor % attName,'(a)') trim(attName)
+ cursor % attValueInt = attValue
+
+ end subroutine mpas_add_att_int0d
+
+
+ subroutine mpas_add_att_int1d(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ integer, dimension(:), intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ if (.not. associated(attList)) then
+ allocate(attList)
+ cursor => attList
+ else
+ cursor => attList
+ do while (associated(cursor % next))
+ cursor => cursor % next
+ end do
+ allocate(cursor % next)
+ cursor => cursor % next
+ end if
+
+ cursor % attType = ATT_INTA
+ allocate(cursor % attValueIntA(size(attValue)))
+ write(cursor % attName,'(a)') trim(attName)
+ cursor % attValueIntA(:) = attValue(:)
+
+ end subroutine mpas_add_att_int1d
+
+
+ subroutine mpas_add_att_real0d(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ if (.not. associated(attList)) then
+ allocate(attList)
+ cursor => attList
+ else
+ cursor => attList
+ do while (associated(cursor % next))
+ cursor => cursor % next
+ end do
+ allocate(cursor % next)
+ cursor => cursor % next
+ end if
+
+ cursor % attType = ATT_REAL
+ write(cursor % attName,'(a)') trim(attName)
+ cursor % attValueReal = attValue
+
+ end subroutine mpas_add_att_real0d
+
+
+ subroutine mpas_add_att_real1d(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), dimension(:), intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ if (.not. associated(attList)) then
+ allocate(attList)
+ cursor => attList
+ else
+ cursor => attList
+ do while (associated(cursor % next))
+ cursor => cursor % next
+ end do
+ allocate(cursor % next)
+ cursor => cursor % next
+ end if
+
+ cursor % attType = ATT_REALA
+ allocate(cursor % attValueRealA(size(attValue)))
+ write(cursor % attName,'(a)') trim(attName)
+ cursor % attValueRealA(:) = attValue(:)
+
+ end subroutine mpas_add_att_real1d
+
+
+ subroutine mpas_add_att_text(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ character (len=*), intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ if (.not. associated(attList)) then
+ allocate(attList)
+ cursor => attList
+ else
+ cursor => attList
+ do while (associated(cursor % next))
+ cursor => cursor % next
+ end do
+ allocate(cursor % next)
+ cursor => cursor % next
+ end if
+
+ cursor % attType = ATT_TEXT
+ write(cursor % attName,'(a)') trim(attName)
+ write(cursor % attValueText,'(a)') trim(attValue)
+
+ end subroutine mpas_add_att_text
+
+
+ subroutine mpas_get_att_int0d(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ integer, intent(out) :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ cursor => attList
+ do while (associated(cursor))
+ if (trim(attName) == trim(cursor % attName)) then
+ if (cursor % attType /= ATT_INT) then
+ if (present(ierr)) ierr = 1 ! Wrong type
+ else
+ attValue = cursor % attValueInt
+ end if
+ return
+ end if
+ cursor => cursor % next
+ end do
+
+ if (present(ierr)) ierr = 1 ! Not found
+
+ end subroutine mpas_get_att_int0d
+
+
+ subroutine mpas_get_att_int1d(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ integer, dimension(:), pointer :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ cursor => attList
+ do while (associated(cursor))
+ if (trim(attName) == trim(cursor % attName)) then
+ if (cursor % attType /= ATT_INTA) then
+ if (present(ierr)) ierr = 1 ! Wrong type
+ else
+ allocate(attValue(size(cursor % attValueIntA)))
+ attValue(:) = cursor % attValueIntA(:)
+ end if
+ return
+ end if
+ cursor => cursor % next
+ end do
+
+ if (present(ierr)) ierr = 1 ! Not found
+
+ end subroutine mpas_get_att_int1d
+
+
+ subroutine mpas_get_att_real0d(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), intent(out) :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ cursor => attList
+ do while (associated(cursor))
+ if (trim(attName) == trim(cursor % attName)) then
+ if (cursor % attType /= ATT_REAL) then
+ if (present(ierr)) ierr = 1 ! Wrong type
+ else
+ attValue = cursor % attValueReal
+ end if
+ return
+ end if
+ cursor => cursor % next
+ end do
+
+ if (present(ierr)) ierr = 1 ! Not found
+
+ end subroutine mpas_get_att_real0d
+
+
+ subroutine mpas_get_att_real1d(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), dimension(:), pointer :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ cursor => attList
+ do while (associated(cursor))
+ if (trim(attName) == trim(cursor % attName)) then
+ if (cursor % attType /= ATT_REALA) then
+ if (present(ierr)) ierr = 1 ! Wrong type
+ else
+ allocate(attValue(size(cursor % attValueRealA)))
+ attValue(:) = cursor % attValueRealA(:)
+ end if
+ return
+ end if
+ cursor => cursor % next
+ end do
+
+ if (present(ierr)) ierr = 1 ! Not found
+
+ end subroutine mpas_get_att_real1d
+
+
+ subroutine mpas_get_att_text(attList, attName, attValue, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ character (len=*), intent(out) :: attValue
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ cursor => attList
+ do while (associated(cursor))
+ if (trim(attName) == trim(cursor % attName)) then
+ if (cursor % attType /= ATT_TEXT) then
+ if (present(ierr)) ierr = 1 ! Wrong type
+ else
+ write(attValue,'(a)') trim(cursor % attValueText)
+ end if
+ return
+ end if
+ cursor => cursor % next
+ end do
+
+ if (present(ierr)) ierr = 1 ! Not found
+
+ end subroutine mpas_get_att_text
+
+
+ subroutine mpas_remove_att(attList, attName, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ character (len=*), intent(in) :: attName
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor, cursor_prev
+
+ if (present(ierr)) ierr = 0
+
+ cursor => attList
+
+ ! Item is at the head of the list
+ if (trim(attName) == trim(cursor % attName)) then
+ attList => cursor % next
+ if (cursor % attType == ATT_REALA) then
+ deallocate(cursor % attValueRealA)
+ else if (cursor % attType == ATT_INTA) then
+ deallocate(cursor % attValueIntA)
+ end if
+ deallocate(cursor)
+ return
+ end if
+
+ cursor_prev => cursor
+ cursor => cursor % next
+ do while (associated(cursor))
+ if (trim(attName) == trim(cursor % attName)) then
+ cursor_prev % next => cursor % next
+
+ if (cursor % attType == ATT_REALA) then
+ deallocate(cursor % attValueRealA)
+ else if (cursor % attType == ATT_INTA) then
+ deallocate(cursor % attValueIntA)
+ end if
+ deallocate(cursor)
+
+ return
+ end if
+
+ cursor_prev => cursor
+ cursor => cursor % next
+ end do
+
+ if (present(ierr)) ierr = 1 ! Not found
+
+ end subroutine mpas_remove_att
+
+
+ subroutine mpas_deallocate_attlist(attList, ierr)
+
+ implicit none
+
+ type (att_list_type), pointer :: attList
+ integer, intent(out), optional :: ierr
+
+ type (att_list_type), pointer :: cursor
+
+ if (present(ierr)) ierr = 0
+
+ cursor => attList
+ do while (associated(cursor))
+ attList => attList % next
+ if (cursor % attType == ATT_REALA) then
+ deallocate(cursor % attValueRealA)
+ else if (cursor % attType == ATT_INTA) then
+ deallocate(cursor % attValueIntA)
+ end if
+ deallocate(cursor)
+ cursor => attList
+ end do
+
+ end subroutine mpas_deallocate_attlist
+
+end module mpas_attlist
Modified: trunk/mpas/src/framework/mpas_block_decomp.F
===================================================================
--- trunk/mpas/src/framework/mpas_block_decomp.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/framework/mpas_block_decomp.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -2,6 +2,7 @@
use mpas_dmpar
use mpas_hash
+ use mpas_sort
type graph
integer :: nVerticesTotal
@@ -12,115 +13,202 @@
integer, dimension(:,:), pointer :: adjacencyList
end type graph
+ integer :: total_blocks
+ logical :: explicitDecomp
+ integer, dimension(:), allocatable :: block_proc_list
+ integer, dimension(:), allocatable :: block_local_id_list
contains
+ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list, block_id, block_start, block_count)!{{{
- subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list)
-
use mpas_configure
implicit none
- type (dm_info), intent(in) :: dminfo
- type (graph), intent(in) :: partial_global_graph_info
- integer, dimension(:), pointer :: local_cell_list
+ type (dm_info), intent(in) :: dminfo !< Input: domain information
+ type (graph), intent(in) :: partial_global_graph_info !< Input: Global graph information
+ integer, dimension(:), pointer :: local_cell_list !< Output: list of cells this processor owns, ordered by block
+ integer, dimension(:), pointer :: block_id !< Output: list of global block id's this processor owns
+ integer, dimension(:), pointer :: block_start !< Output: offset in local_cell_list for this blocks list of cells
+ integer, dimension(:), pointer :: block_count !< Output: number of cells in blocks
+ integer, dimension(:), pointer :: global_block_list
integer, dimension(:), pointer :: global_cell_list
integer, dimension(:), pointer :: global_start
- integer :: i, j, owner, iunit, istatus
+ integer, dimension(:), allocatable :: local_block_list
+ integer, dimension(:,:), allocatable :: sorted_local_cell_list
+
+ integer :: i, j, global_block_id, local_block_id, owning_proc, iunit, istatus
+ integer :: blocks_per_proc
integer, dimension(:), pointer :: local_nvertices
character (len=256) :: filename
- if (dminfo % nprocs > 1) then
+ if(config_number_of_blocks == 0) then
+ total_blocks = dminfo % nProcs
+ else
+ total_blocks = config_number_of_blocks
+ end if
- allocate(local_nvertices(dminfo % nprocs))
- allocate(global_start(dminfo % nprocs))
- allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
+ explicitDecomp = config_explicit_proc_decomp
- if (dminfo % my_proc_id == IO_NODE) then
+ call mpas_build_block_proc_list(dminfo)
+ call mpas_get_blocks_per_proc(dminfo, dminfo % my_proc_id, blocks_per_proc)
- iunit = 50 + dminfo % my_proc_id
- if (dminfo % nprocs < 10) then
- write(filename,'(a,i1)') trim(config_decomp_file_prefix), dminfo % nprocs
- else if (dminfo % nprocs < 100) then
- write(filename,'(a,i2)') trim(config_decomp_file_prefix), dminfo % nprocs
- else if (dminfo % nprocs < 1000) then
- write(filename,'(a,i3)') trim(config_decomp_file_prefix), dminfo % nprocs
- else if (dminfo % nprocs < 10000) then
- write(filename,'(a,i4)') trim(config_decomp_file_prefix), dminfo % nprocs
- else if (dminfo % nprocs < 100000) then
- write(filename,'(a,i5)') trim(config_decomp_file_prefix), dminfo % nprocs
- end if
-
- open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus)
-
- if (istatus /= 0) then
- write(0,*) 'Could not open block decomposition file for ',dminfo % nprocs,' tasks.'
- write(0,*) 'Filename: ',trim(filename)
- call mpas_dmpar_abort(dminfo)
- end if
-
- local_nvertices(:) = 0
- do i=1,partial_global_graph_info % nVerticesTotal
- read(unit=iunit, fmt=*) owner
- local_nvertices(owner+1) = local_nvertices(owner+1) + 1
- end do
-
-! allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
+ if(total_blocks > 1) then
+ allocate(local_nvertices(dminfo % nprocs))
+ allocate(global_start(dminfo % nprocs))
+ allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
+ allocate(global_block_list(partial_global_graph_info % nVerticesTotal))
+
+ if (dminfo % my_proc_id == IO_NODE) then
+
+ iunit = 50 + dminfo % my_proc_id
+ if (total_blocks < 10) then
+ write(filename,'(a,i1)') trim(config_block_decomp_file_prefix), total_blocks
+ else if (total_blocks < 100) then
+ write(filename,'(a,i2)') trim(config_block_decomp_file_prefix), total_blocks
+ else if (total_blocks < 1000) then
+ write(filename,'(a,i3)') trim(config_block_decomp_file_prefix), total_blocks
+ else if (total_blocks < 10000) then
+ write(filename,'(a,i4)') trim(config_block_decomp_file_prefix), total_blocks
+ else if (total_blocks < 100000) then
+ write(filename,'(a,i5)') trim(config_block_decomp_file_prefix), total_blocks
+ end if
+
+ open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus)
+
+ if (istatus /= 0) then
+ write(0,*) 'Could not open block decomposition file for ',total_blocks,' blocks.'
+ write(0,*) 'Filename: ',trim(filename)
+ call mpas_dmpar_abort(dminfo)
+ end if
+
+ local_nvertices(:) = 0
+ do i=1,partial_global_graph_info % nVerticesTotal
+ read(unit=iunit, fmt=*) global_block_id
+ call mpas_get_owning_proc(dminfo, global_block_id, owning_proc)
+ local_nvertices(owning_proc+1) = local_nvertices(owning_proc+1) + 1
+ end do
+
+ allocate(global_cell_list(partial_global_graph_info % nVerticesTotal))
+
+ global_start(1) = 1
+ do i=2,dminfo % nprocs
+ global_start(i) = global_start(i-1) + local_nvertices(i-1)
+ end do
+
+ rewind(unit=iunit)
+
+ do i=1,partial_global_graph_info % nVerticesTotal
+ read(unit=iunit, fmt=*) global_block_id
+ call mpas_get_owning_proc(dminfo, global_block_id, owning_proc)
+
+ global_cell_list(global_start(owning_proc+1)) = i
+ global_block_list(global_start(owning_proc+1)) = global_block_id
+ global_start(owning_proc+1) = global_start(owning_proc+1) + 1
+ end do
+
+ global_start(1) = 0
+ do i=2,dminfo % nprocs
+ global_start(i) = global_start(i-1) + local_nvertices(i-1)
+ end do
- global_start(1) = 1
- do i=2,dminfo % nprocs
- global_start(i) = global_start(i-1) + local_nvertices(i-1)
- end do
-
- rewind(unit=iunit)
-
- do i=1,partial_global_graph_info % nVerticesTotal
- read(unit=iunit, fmt=*) owner
- global_cell_list(global_start(owner+1)) = i
- global_start(owner+1) = global_start(owner+1) + 1
- end do
+ close(unit=iunit)
- global_start(1) = 0
- do i=2,dminfo % nprocs
- global_start(i) = global_start(i-1) + local_nvertices(i-1)
- end do
+ call mpas_dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
+ allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
+ allocate(local_block_list(local_nvertices(dminfo % my_proc_id + 1)))
- close(unit=iunit)
+ call mpas_dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
+ global_start, local_nvertices, global_cell_list, local_cell_list)
- call mpas_dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
- allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
+ call mpas_dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
+ global_start, local_nvertices, global_block_list, local_block_list)
- call mpas_dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
- global_start, local_nvertices, global_cell_list, local_cell_list)
+ else
- else
+ call mpas_dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
+ allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
+ allocate(local_block_list(local_nvertices(dminfo % my_proc_id + 1)))
+
+ call mpas_dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
+ global_start, local_nvertices, global_cell_list, local_cell_list)
- call mpas_dmpar_bcast_ints(dminfo, dminfo % nprocs, local_nvertices)
- allocate(local_cell_list(local_nvertices(dminfo % my_proc_id + 1)))
+ call mpas_dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
+ global_start, local_nvertices, global_block_list, local_block_list)
+ end if
+
+ allocate(sorted_local_cell_list(2, local_nvertices(dminfo % my_proc_id + 1)))
+ allocate(block_id(blocks_per_proc))
+ allocate(block_start(blocks_per_proc))
+ allocate(block_count(blocks_per_proc))
- call mpas_dmpar_scatter_ints(dminfo, dminfo % nprocs, local_nvertices(dminfo % my_proc_id + 1), &
- global_start, local_nvertices, global_cell_list, local_cell_list)
+ do i = 1, blocks_per_proc
+ block_start = 0
+ block_count = 0
+ end do
- end if
+ do i = 1,local_nvertices(dminfo % my_proc_id +1)
+ call mpas_get_local_block_id(dminfo, local_block_list(i), local_block_id)
+
+ block_id(local_block_id+1) = local_block_list(i)
+
+ sorted_local_cell_list(1, i) = local_block_list(i)
+ sorted_local_cell_list(2, i) = local_cell_list(i)
+
+ block_count(local_block_id+1) = block_count(local_block_id+1) + 1
+ end do
- deallocate(local_nvertices)
- deallocate(global_start)
- deallocate(global_cell_list)
+ call quicksort(local_nvertices(dminfo % my_proc_id + 1), sorted_local_cell_list)
+
+ do i = 1, local_nvertices(dminfo % my_proc_id+1)
+ local_cell_list(i) = sorted_local_cell_list(2, i)
+ end do
+
+ do i = 2,blocks_per_proc
+ block_start(i) = block_start(i-1) + block_count(i-1)
+ end do
+
+ !dwj 01/31/12 debugging multiple blocks
+! do i=1,local_nvertices(dminfo % my_proc_id +1)
+! call mpas_get_local_block_id(dminfo, sorted_local_cell_list(1, i), local_block_id)
+! write(*,*) sorted_local_cell_list(1, i), local_block_id, sorted_local_cell_list(2,i)
+! end do
+
+ deallocate(sorted_local_cell_list)
+ deallocate(local_block_list)
+ deallocate(local_nvertices)
+ deallocate(global_start)
+ deallocate(global_cell_list)
+ deallocate(global_block_list)
else
- allocate(local_cell_list(partial_global_graph_info % nVerticesTotal))
- do i=1,size(local_cell_list)
- local_cell_list(i) = i
- end do
- endif
+ allocate(local_cell_list(partial_global_graph_info % nVerticesTotal))
+ allocate(block_id(1))
+ allocate(block_start(1))
+ allocate(block_count(1))
+ block_id(1) = 0
+ block_start(1) = 0
+ block_count(1) = size(local_cell_list)
+ do i=1,size(local_cell_list)
+ local_cell_list(i) = i
+ end do
+ end if
- end subroutine mpas_block_decomp_cells_for_proc
+ !dwj 01/31/12 debugging multiple blocks
+! write(*,*) 'Blocks per proc = ', blocks_per_proc, 'total_blocks = ', total_blocks
+! do i=1,blocks_per_proc
+! write(*,*) block_id(i), block_start(i), block_count(i)
+! end do
- subroutine mpas_block_decomp_partitioned_edge_list(nCells, cellIDList, maxCells, nEdges, cellsOnEdge, edgeIDList, ghostEdgeStart)
+! call mpas_dmpar_abort(dminfo)
+ end subroutine mpas_block_decomp_cells_for_proc!}}}
+
+ subroutine mpas_block_decomp_partitioned_edge_list(nCells, cellIDList, maxCells, nEdges, cellsOnEdge, edgeIDList, ghostEdgeStart)!{{{
+
implicit none
integer, intent(in) :: nCells, maxCells, nEdges
@@ -172,11 +260,10 @@
call mpas_hash_destroy(h)
- end subroutine mpas_block_decomp_partitioned_edge_list
+ end subroutine mpas_block_decomp_partitioned_edge_list!}}}
+ subroutine mpas_block_decomp_all_edges_in_block(maxEdges, nCells, nEdgesOnCell, edgesOnCell, nEdges, edgeList)!{{{
- subroutine mpas_block_decomp_all_edges_in_block(maxEdges, nCells, nEdgesOnCell, edgesOnCell, nEdges, edgeList)
-
implicit none
integer, intent(in) :: maxEdges, nCells
@@ -226,11 +313,10 @@
'Listed fewer edges than expected.'
end if
- end subroutine mpas_block_decomp_all_edges_in_block
+ end subroutine mpas_block_decomp_all_edges_in_block!}}}
+ subroutine mpas_block_decomp_add_halo(dminfo, local_graph_info, local_graph_with_halo)!{{{
- subroutine mpas_block_decomp_add_halo(dminfo, local_graph_info, local_graph_with_halo)
-
implicit none
type (dm_info), intent(in) :: dminfo
@@ -301,6 +387,132 @@
call mpas_hash_destroy(h)
- end subroutine mpas_block_decomp_add_halo
+ end subroutine mpas_block_decomp_add_halo!}}}
+ subroutine mpas_get_blocks_per_proc(dminfo, proc_number, blocks_per_proc)!{{{
+ type(dm_info), intent(in) :: dminfo !< Input: Domain Information
+ integer, intent(in) :: proc_number !< Input: Processor number
+ integer, intent(out) :: blocks_per_proc !< Output: Number of blocks proc_number computes on
+
+ integer :: blocks_per_proc_min, even_blocks, remaining_blocks
+
+ blocks_per_proc_min = total_blocks / dminfo % nProcs
+ remaining_blocks = total_blocks - (blocks_per_proc_min * dminfo % nProcs)
+ even_blocks = total_blocks - remaining_blocks
+
+ blocks_per_proc = blocks_per_proc_min
+
+ if(proc_number .le. remaining_blocks) then
+ block_per_proc = blocks_per_proc + 1
+ endif
+
+ end subroutine mpas_get_blocks_per_proc!}}}
+
+ subroutine mpas_get_local_block_id(dminfo, global_block_number, local_block_number)!{{{
+ type(dm_info), intent(in) :: dminfo !< Input: Domain Information
+ integer, intent(in) :: global_block_number !< Input: Global block id from 0 to config_number_of_blocks-1
+ integer, intent(out) :: local_block_number !< Output: Local block id on owning processor from 0 to blocks_per_proc
+
+ integer :: blocks_per_proc_min, even_blocks, remaining_blocks
+
+ if(.not.explicitDecomp) then
+ blocks_per_proc_min = total_blocks / dminfo % nProcs
+ remaining_blocks = total_blocks - (blocks_per_proc_min * dminfo % nProcs)
+ even_blocks = total_blocks - remaining_blocks
+
+ if(global_block_number > even_blocks) then
+ local_block_number = blocks_per_proc_min
+ else
+ local_block_number = mod(global_block_number, blocks_per_proc_min)
+ end if
+ else
+ local_block_number = block_local_id_list(global_block_number+1)
+ end if
+ end subroutine mpas_get_local_block_id!}}}
+
+ subroutine mpas_get_owning_proc(dminfo, global_block_number, owning_proc)!{{{
+ type(dm_info), intent(in) :: dminfo !< Input: Domain Information
+ integer, intent(in) :: global_block_number !< Input: Global block id from 0 to config_number_of_blocks-1
+ integer, intent(out) :: owning_proc !< Output: Processor number that owns block global_block_number
+
+ integer :: blocks_per_proc_min, even_blocks, remaining_blocks
+
+ if(.not.explicitDecomp) then
+ blocks_per_proc_min = total_blocks / dminfo % nProcs
+ remaining_blocks = total_blocks - (blocks_per_proc_min * dminfo % nProcs)
+ even_blocks = total_blocks - remaining_blocks
+
+ if(global_block_number > even_blocks) then
+ owning_proc = global_block_number - even_blocks
+ else
+ owning_proc = global_block_number / blocks_per_proc_min
+ end if
+ else
+ owning_proc = block_proc_list(global_block_number+1)
+ end if
+ end subroutine mpas_get_owning_proc!}}}
+
+ subroutine mpas_build_block_proc_list(dminfo)!{{{
+
+ use mpas_configure
+
+ implicit none
+
+ type(dm_info), intent(in) :: dminfo
+
+ integer :: iounit, istatus, i, owning_proc
+ character (len=256) :: filename
+
+ integer, dimension(:), allocatable :: block_counter
+
+ if(.not.explicitDecomp) return
+
+ allocate(block_proc_list(total_blocks))
+ allocate(block_local_id_list(total_blocks))
+
+ if (dminfo % my_proc_id == IO_NODE) then
+ allocate(block_counter(dminfo % nProcs))
+ block_counter = 0
+
+ iounit = 51 + dminfo % my_proc_id
+ if (dminfo % nProcs < 10) then
+ write(filename,'(a,i1)') trim(config_proc_decomp_file_prefix), dminfo % nProcs
+ else if (dminfo % nProcs < 100) then
+ write(filename,'(a,i2)') trim(config_proc_decomp_file_prefix), dminfo % nProcs
+ else if (dminfo % nProcs < 1000) then
+ write(filename,'(a,i3)') trim(config_proc_decomp_file_prefix), dminfo % nProcs
+ else if (dminfo % nProcs < 10000) then
+ write(filename,'(a,i4)') trim(config_proc_decomp_file_prefix), dminfo % nProcs
+ else if (dminfo % nProcs < 100000) then
+ write(filename,'(a,i5)') trim(config_proc_decomp_file_prefix), dminfo % nProcs
+ end if
+
+ open(unit=iounit, file=trim(filename), form='formatted', status='old', iostat=istatus)
+
+ do i=1,total_blocks
+ read(unit=iounit, fmt=*) owning_proc
+
+ block_proc_list(i) = owning_proc
+ block_local_id_list(i) = block_counter(owning_proc+1)
+
+ block_counter(owning_proc+1) = block_counter(owning_proc+1) + 1
+ end do
+
+ close(unit=iounit)
+ deallocate(block_counter)
+ call mpas_dmpar_bcast_ints(dminfo, total_blocks, block_proc_list)
+ call mpas_dmpar_bcast_ints(dminfo, total_blocks, block_local_id_list)
+ else
+ call mpas_dmpar_bcast_ints(dminfo, total_blocks, block_proc_list)
+ call mpas_dmpar_bcast_ints(dminfo, total_blocks, block_local_id_list)
+ endif
+
+ end subroutine mpas_build_block_proc_list!}}}
+
+ subroutine mpas_finish_block_proc_list()!{{{
+ if(.not.explicitDecomp) return
+ deallocate(block_proc_list)
+ deallocate(block_local_id_list)
+ end subroutine mpas_finish_block_proc_list!}}}
+
end module mpas_block_decomp
Modified: trunk/mpas/src/framework/mpas_dmpar.F
===================================================================
--- trunk/mpas/src/framework/mpas_dmpar.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/framework/mpas_dmpar.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -1,6 +1,7 @@
module mpas_dmpar
- use mpas_kind_types
+ use mpas_dmpar_types
+ use mpas_grid_types
use mpas_sort
#ifdef _MPI
@@ -18,23 +19,6 @@
integer, parameter :: BUFSIZE = 6000
- type dm_info
- integer :: nprocs, my_proc_id, comm, info
- logical :: using_external_comm
- end type dm_info
-
-
- type exchange_list
- integer :: procID
- integer :: nlist
- integer, dimension(:), pointer :: list
- type (exchange_list), pointer :: next
- real (kind=RKIND), dimension(:), pointer :: rbuffer
- integer, dimension(:), pointer :: ibuffer
- integer :: reqID
- end type exchange_list
-
-
interface mpas_dmpar_alltoall_field
module procedure mpas_dmpar_alltoall_field1d_integer
module procedure mpas_dmpar_alltoall_field2d_integer
@@ -43,7 +27,30 @@
module procedure mpas_dmpar_alltoall_field3d_real
end interface
+ private :: mpas_dmpar_alltoall_field1d_integer
+ private :: mpas_dmpar_alltoall_field2d_integer
+ private :: mpas_dmpar_alltoall_field1d_real
+ private :: mpas_dmpar_alltoall_field2d_real
+ private :: mpas_dmpar_alltoall_field3d_real
+
+ interface mpas_dmpar_exch_halo_field
+ module procedure mpas_dmpar_exch_halo_field1d_integer
+ module procedure mpas_dmpar_exch_halo_field2d_integer
+ module procedure mpas_dmpar_exch_halo_field3d_integer
+ module procedure mpas_dmpar_exch_halo_field1d_real
+ module procedure mpas_dmpar_exch_halo_field2d_real
+ module procedure mpas_dmpar_exch_halo_field3d_real
+ end interface
+
+ private :: mpas_dmpar_exch_halo_field1d_integer
+ private :: mpas_dmpar_exch_halo_field2d_integer
+ private :: mpas_dmpar_exch_halo_field3d_integer
+ private :: mpas_dmpar_exch_halo_field1d_real
+ private :: mpas_dmpar_exch_halo_field2d_real
+ private :: mpas_dmpar_exch_halo_field3d_real
+
+
contains
@@ -565,7 +572,7 @@
subroutine mpas_dmpar_get_owner_list(dminfo, &
nOwnedList, nNeededList, &
ownedList, neededList, &
- sendList, recvList)
+ sendList, recvList, inOffset)
implicit none
@@ -575,9 +582,10 @@
integer, dimension(nNeededList), intent(in) :: neededList
type (exchange_list), pointer :: sendList
type (exchange_list), pointer :: recvList
+ integer, optional :: inOffset
integer :: i, j, k, kk
- integer :: totalSize, nMesgRecv, nMesgSend, recvNeighbor, sendNeighbor, currentProc
+ integer :: totalSize, nMesgRecv, nMesgSend, recvNeighbor, sendNeighbor, currentProc, offset
integer :: numToSend, numToRecv
integer, dimension(nOwnedList) :: recipientList
integer, dimension(2,nOwnedList) :: ownedListSorted
@@ -585,6 +593,7 @@
type (exchange_list), pointer :: sendListPtr, recvListPtr
integer :: mpi_ierr, mpi_rreq, mpi_sreq
+
#ifdef _MPI
allocate(sendList)
allocate(recvList)
@@ -593,6 +602,11 @@
sendListPtr => sendList
recvListPtr => recvList
+ offset = 0
+ if(present(inOffset)) then
+ offset = inOffset
+ end if
+
do i=1,nOwnedList
ownedListSorted(1,i) = ownedList(i)
ownedListSorted(2,i) = i
@@ -635,6 +649,7 @@
allocate(sendListPtr % next)
sendListPtr => sendListPtr % next
sendListPtr % procID = currentProc
+ sendListPtr % blockID = currentProc ! Currently, we have just one block per task, so blockID = procID
sendListPtr % nlist = numToSend
allocate(sendListPtr % list(numToSend))
nullify(sendListPtr % next)
@@ -668,13 +683,14 @@
allocate(recvListPtr % next)
recvListPtr => recvListPtr % next
recvListPtr % procID = i
+ recvListPtr % blockID = i ! Currently, we have just one block per task, so blockID = procID
recvListPtr % nlist = numToRecv
allocate(recvListPtr % list(numToRecv))
nullify(recvListPtr % next)
kk = 1
do j=1,nNeededList
if (ownerListIn(j) == -i) then
- recvListPtr % list(kk) = j
+ recvListPtr % list(kk) = j + offset
kk = kk + 1
end if
end do
@@ -696,6 +712,7 @@
#else
allocate(recvList)
recvList % procID = dminfo % my_proc_id
+ recvList % blockID = dminfo % my_proc_id ! Currently, we have just one block per task, so blockID = procID
recvList % nlist = nNeededList
allocate(recvList % list(nNeededList))
nullify(recvList % next)
@@ -705,6 +722,7 @@
allocate(sendList)
sendList % procID = dminfo % my_proc_id
+ sendList % blockID = dminfo % my_proc_id ! Currently, we have just one block per task, so blockID = procID
sendList % nlist = nOwnedList
allocate(sendList % list(nOwnedList))
nullify(sendList % next)
@@ -1467,21 +1485,27 @@
end subroutine mpas_unpack_recv_buf3d_integer
- subroutine mpas_dmpar_exch_halo_field1d_integer(dminfo, array, dim1, sendList, recvList)
+ subroutine mpas_dmpar_exch_halo_field1d_integer(field, haloLayers)
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1
- integer, dimension(*), intent(inout) :: array
+ type (field1DInteger), intent(inout) :: field
+ integer, dimension(:), intent(in), optional :: haloLayers
+
+ type (dm_info) :: dminfo
type (exchange_list), pointer :: sendList, recvList
-
type (exchange_list), pointer :: sendListPtr, recvListPtr
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: mpi_ierr
+ integer, dimension(size(field % dimSizes)) :: dims
#ifdef _MPI
+ dminfo = field % block % domain % dminfo
+ dims = field % dimSizes
+
+ call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+
recvListPtr => recvList
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
@@ -1496,7 +1520,7 @@
do while (associated(sendListPtr))
if (sendListPtr % procID /= dminfo % my_proc_id) then
allocate(sendListPtr % ibuffer(sendListPtr % nlist))
- call mpas_pack_send_buf1d_integer(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call mpas_pack_send_buf1d_integer(dims(1), field % array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % ibuffer, nPacked, lastPackedIdx)
call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
end if
@@ -1507,7 +1531,7 @@
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call mpas_unpack_recv_buf1d_integer(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ call mpas_unpack_recv_buf1d_integer(dims(1), field % array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
deallocate(recvListPtr % ibuffer)
end if
recvListPtr => recvListPtr % next
@@ -1522,31 +1546,40 @@
sendListPtr => sendListPtr % next
end do
+ call mpas_destroy_exchange_list(sendList)
+ call mpas_destroy_exchange_list(recvList)
+
#endif
end subroutine mpas_dmpar_exch_halo_field1d_integer
- subroutine mpas_dmpar_exch_halo_field2d_integer(dminfo, array, dim1, dim2, sendList, recvList)
+ subroutine mpas_dmpar_exch_halo_field2d_integer(field, haloLayers)
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2
- integer, dimension(dim1,*), intent(inout) :: array
+ type (field2DInteger), intent(inout) :: field
+ integer, dimension(:), intent(in), optional :: haloLayers
+
+ type (dm_info) :: dminfo
type (exchange_list), pointer :: sendList, recvList
-
type (exchange_list), pointer :: sendListPtr, recvListPtr
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: mpi_ierr
integer :: d2
+ integer, dimension(size(field % dimSizes)) :: dims
#ifdef _MPI
+ dminfo = field % block % domain % dminfo
+ dims = field % dimSizes
+
+ call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+
recvListPtr => recvList
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * recvListPtr % nlist
+ d2 = dims(1) * recvListPtr % nlist
allocate(recvListPtr % ibuffer(d2))
call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
@@ -1557,9 +1590,9 @@
sendListPtr => sendList
do while (associated(sendListPtr))
if (sendListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * sendListPtr % nlist
+ d2 = dims(1) * sendListPtr % nlist
allocate(sendListPtr % ibuffer(d2))
- call mpas_pack_send_buf2d_integer(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call mpas_pack_send_buf2d_integer(1, dims(1), dims(2), field % array, sendListPtr, 1, d2, sendListPtr % ibuffer, nPacked, lastPackedIdx)
call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
end if
@@ -1570,8 +1603,8 @@
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d2 = dim1 * recvListPtr % nlist
- call mpas_unpack_recv_buf2d_integer(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ d2 = dims(1) * recvListPtr % nlist
+ call mpas_unpack_recv_buf2d_integer(1, dims(1), dims(2), field % array, recvListPtr, 1, d2, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
deallocate(recvListPtr % ibuffer)
end if
recvListPtr => recvListPtr % next
@@ -1586,31 +1619,40 @@
sendListPtr => sendListPtr % next
end do
+ call mpas_destroy_exchange_list(sendList)
+ call mpas_destroy_exchange_list(recvList)
+
#endif
end subroutine mpas_dmpar_exch_halo_field2d_integer
- subroutine mpas_dmpar_exch_halo_field3d_integer(dminfo, array, dim1, dim2, dim3, sendList, recvList)
+ subroutine mpas_dmpar_exch_halo_field3d_integer(field, haloLayers)
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2, dim3
- integer, dimension(dim1,dim2,*), intent(inout) :: array
+ type (field3DInteger), intent(inout) :: field
+ integer, dimension(:), intent(in), optional :: haloLayers
+
+ type (dm_info) :: dminfo
type (exchange_list), pointer :: sendList, recvList
-
type (exchange_list), pointer :: sendListPtr, recvListPtr
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: mpi_ierr
integer :: d3
+ integer, dimension(size(field % dimSizes)) :: dims
#ifdef _MPI
+ dminfo = field % block % domain % dminfo
+ dims = field % dimSizes
+
+ call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+
recvListPtr => recvList
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * recvListPtr % nlist
+ d3 = dims(1) * dims(2) * recvListPtr % nlist
allocate(recvListPtr % ibuffer(d3))
call MPI_Irecv(recvListPtr % ibuffer, d3, MPI_INTEGERKIND, &
recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
@@ -1621,9 +1663,9 @@
sendListPtr => sendList
do while (associated(sendListPtr))
if (sendListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * sendListPtr % nlist
+ d3 = dims(1) * dims(2) * sendListPtr % nlist
allocate(sendListPtr % ibuffer(d3))
- call mpas_pack_send_buf3d_integer(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
+ call mpas_pack_send_buf3d_integer(1, dims(1), 1, dims(2), dims(3), field % array, sendListPtr, 1, d3, &
sendListPtr % ibuffer, nPacked, lastPackedIdx)
call MPI_Isend(sendListPtr % ibuffer, d3, MPI_INTEGERKIND, &
sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
@@ -1635,8 +1677,8 @@
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d3 = dim1 * dim2 * recvListPtr % nlist
- call mpas_unpack_recv_buf3d_integer(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
+ d3 = dims(1) * dims(2) * recvListPtr % nlist
+ call mpas_unpack_recv_buf3d_integer(1, dims(1), 1, dims(2), dims(3), field % array, recvListPtr, 1, d3, &
recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
deallocate(recvListPtr % ibuffer)
end if
@@ -1652,6 +1694,9 @@
sendListPtr => sendListPtr % next
end do
+ call mpas_destroy_exchange_list(sendList)
+ call mpas_destroy_exchange_list(recvList)
+
#endif
end subroutine mpas_dmpar_exch_halo_field3d_integer
@@ -1747,21 +1792,27 @@
end subroutine mpas_unpack_recv_buf3d_real
- subroutine mpas_dmpar_exch_halo_field1d_real(dminfo, array, dim1, sendList, recvList)
+ subroutine mpas_dmpar_exch_halo_field1d_real(field, haloLayers)
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1
- real (kind=RKIND), dimension(*), intent(inout) :: array
+ type (field1DReal), intent(inout) :: field
+ integer, dimension(:), intent(in), optional :: haloLayers
+
+ type (dm_info) :: dminfo
type (exchange_list), pointer :: sendList, recvList
-
type (exchange_list), pointer :: sendListPtr, recvListPtr
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: mpi_ierr
+ integer, dimension(size(field % dimSizes)) :: dims
#ifdef _MPI
+ dminfo = field % block % domain % dminfo
+ dims = field % dimSizes
+
+ call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+
recvListPtr => recvList
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
@@ -1771,12 +1822,12 @@
end if
recvListPtr => recvListPtr % next
end do
-
+
sendListPtr => sendList
do while (associated(sendListPtr))
if (sendListPtr % procID /= dminfo % my_proc_id) then
allocate(sendListPtr % rbuffer(sendListPtr % nlist))
- call mpas_pack_send_buf1d_real(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call mpas_pack_send_buf1d_real(dims(1), field % array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % rbuffer, nPacked, lastPackedIdx)
call MPI_Isend(sendListPtr % rbuffer, sendListPtr % nlist, MPI_REALKIND, &
sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
end if
@@ -1787,7 +1838,7 @@
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- call mpas_unpack_recv_buf1d_real(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ call mpas_unpack_recv_buf1d_real(dims(1), field % array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
deallocate(recvListPtr % rbuffer)
end if
recvListPtr => recvListPtr % next
@@ -1802,44 +1853,54 @@
sendListPtr => sendListPtr % next
end do
+ call mpas_destroy_exchange_list(sendList)
+ call mpas_destroy_exchange_list(recvList)
+
#endif
end subroutine mpas_dmpar_exch_halo_field1d_real
- subroutine mpas_dmpar_exch_halo_field2d_real(dminfo, array, dim1, dim2, sendList, recvList)
+ subroutine mpas_dmpar_exch_halo_field2d_real(field, haloLayers)
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2
- real (kind=RKIND), dimension(dim1,*), intent(inout) :: array
+ type (field2DReal), intent(inout) :: field
+ integer, dimension(:), intent(in), optional :: haloLayers
+
+ type (dm_info) :: dminfo
type (exchange_list), pointer :: sendList, recvList
-
type (exchange_list), pointer :: sendListPtr, recvListPtr
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: mpi_ierr
integer :: d2
+ integer, dimension(size(field % dimSizes)) :: dims
+
#ifdef _MPI
+ dminfo = field % block % domain % dminfo
+ dims = field % dimSizes
+
+ call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+
recvListPtr => recvList
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * recvListPtr % nlist
+ d2 = dims(1) * recvListPtr % nlist
allocate(recvListPtr % rbuffer(d2))
call MPI_Irecv(recvListPtr % rbuffer, d2, MPI_REALKIND, &
recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
end if
recvListPtr => recvListPtr % next
end do
-
+
sendListPtr => sendList
do while (associated(sendListPtr))
if (sendListPtr % procID /= dminfo % my_proc_id) then
- d2 = dim1 * sendListPtr % nlist
+ d2 = dims(1) * sendListPtr % nlist
allocate(sendListPtr % rbuffer(d2))
- call mpas_pack_send_buf2d_real(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % rbuffer, nPacked, lastPackedIdx)
+ call mpas_pack_send_buf2d_real(1, dims(1), dims(2), field % array, sendListPtr, 1, d2, sendListPtr % rbuffer, nPacked, lastPackedIdx)
call MPI_Isend(sendListPtr % rbuffer, d2, MPI_REALKIND, &
sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
end if
@@ -1850,13 +1911,13 @@
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d2 = dim1 * recvListPtr % nlist
- call mpas_unpack_recv_buf2d_real(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
+ d2 = dims(1) * recvListPtr % nlist
+ call mpas_unpack_recv_buf2d_real(1, dims(1), dims(2), field % array, recvListPtr, 1, d2, recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
deallocate(recvListPtr % rbuffer)
end if
recvListPtr => recvListPtr % next
end do
-
+
sendListPtr => sendList
do while (associated(sendListPtr))
if (sendListPtr % procID /= dminfo % my_proc_id) then
@@ -1866,31 +1927,40 @@
sendListPtr => sendListPtr % next
end do
+ call mpas_destroy_exchange_list(sendList)
+ call mpas_destroy_exchange_list(recvList)
+
#endif
end subroutine mpas_dmpar_exch_halo_field2d_real
- subroutine mpas_dmpar_exch_halo_field3d_real(dminfo, array, dim1, dim2, dim3, sendList, recvList)
+ subroutine mpas_dmpar_exch_halo_field3d_real(field, haloLayers)
implicit none
- type (dm_info), intent(in) :: dminfo
- integer, intent(in) :: dim1, dim2, dim3
- real (kind=RKIND), dimension(dim1,dim2,*), intent(inout) :: array
+ type (field3DReal), intent(inout) :: field
+ integer, dimension(:), intent(in), optional :: haloLayers
+
+ type (dm_info) :: dminfo
type (exchange_list), pointer :: sendList, recvList
-
type (exchange_list), pointer :: sendListPtr, recvListPtr
integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
integer :: mpi_ierr
integer :: d3
+ integer, dimension(size(field % dimSizes)) :: dims
#ifdef _MPI
+ dminfo = field % block % domain % dminfo
+ dims = field % dimSizes
+
+ call mpas_aggregate_exchange_lists(dminfo % my_proc_id, haloLayers, field % sendList, field % recvList, sendList, recvList)
+
recvListPtr => recvList
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * recvListPtr % nlist
+ d3 = dims(1) * dims(2) * recvListPtr % nlist
allocate(recvListPtr % rbuffer(d3))
call MPI_Irecv(recvListPtr % rbuffer, d3, MPI_REALKIND, &
recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
@@ -1901,9 +1971,9 @@
sendListPtr => sendList
do while (associated(sendListPtr))
if (sendListPtr % procID /= dminfo % my_proc_id) then
- d3 = dim1 * dim2 * sendListPtr % nlist
+ d3 = dims(1) * dims(2) * sendListPtr % nlist
allocate(sendListPtr % rbuffer(d3))
- call mpas_pack_send_buf3d_real(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
+ call mpas_pack_send_buf3d_real(1, dims(1), 1, dims(2), dims(3), field % array, sendListPtr, 1, d3, &
sendListPtr % rbuffer, nPacked, lastPackedIdx)
call MPI_Isend(sendListPtr % rbuffer, d3, MPI_REALKIND, &
sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
@@ -1915,8 +1985,8 @@
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
- d3 = dim1 * dim2 * recvListPtr % nlist
- call mpas_unpack_recv_buf3d_real(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
+ d3 = dims(1) * dims(2) * recvListPtr % nlist
+ call mpas_unpack_recv_buf3d_real(1, dims(1), 1, dims(2), dims(3), field % array, recvListPtr, 1, d3, &
recvListPtr % rbuffer, nUnpacked, lastUnpackedIdx)
deallocate(recvListPtr % rbuffer)
end if
@@ -1932,9 +2002,194 @@
sendListPtr => sendListPtr % next
end do
+ call mpas_destroy_exchange_list(sendList)
+ call mpas_destroy_exchange_list(recvList)
+
#endif
end subroutine mpas_dmpar_exch_halo_field3d_real
+ subroutine mpas_aggregate_exchange_lists(myProcID, haloLayersIn, sendListArray, recvListArray, aggregateSendList, aggregateRecvList)
+
+ implicit none
+
+ !--- in variables ---!
+ integer, intent(in) :: myProcID
+ integer, dimension(:), intent(in), target, optional :: haloLayersIn
+ type (exchange_list), dimension(:), pointer :: sendListArray, recvListArray
+
+ !--- out variabls ---!
+ type (exchange_list), pointer :: aggregateSendList, aggregateRecvList
+
+ !--- local variables ---!
+ integer :: i, j
+ integer, dimension(:), pointer :: haloLayers
+ type (exchange_list), pointer :: inListPtr, aggListPtr
+ logical :: blockAdded
+ logical :: listInitilized
+
+ if (present(haloLayersIn)) then
+ haloLayers => haloLayersIn
+ else
+ allocate(haloLayers(size(sendListArray)))
+ do i=1, size(haloLayers)
+ haloLayers(i) = i
+ end do
+ end if
+
+ nullify(aggregateSendList)
+ nullify(aggregateRecvList)
+
+ do i=1, size(haloLayers)
+
+ inListPtr => sendListArray(haloLayers(i)) % next
+ do while(associated(inListPtr))
+
+ blockAdded = .false.
+ aggListPtr => aggregateSendList
+
+ do while(associated(aggListPtr))
+ if(inListPtr % blockID == aggListPtr % blockID) then
+ if(inListPtr % procID .ne. myProcID) then
+ call mpas_merge_integer_arrays(aggListPtr % list, aggListPtr % nlist, inListPtr % list)
+ end if
+ blockAdded = .true.
+ exit
+ end if
+ aggListPtr => aggListPtr % next
+ end do
+
+ if(.not. blockAdded) then
+
+ if (.not. associated(aggregateSendList)) then
+ allocate(aggregateSendList)
+ nullify(aggregateSendList % next)
+ aggListPtr => aggregateSendList
+ else
+ aggListPtr => aggregateSendList
+ do while(associated(aggListPtr % next))
+ aggListPtr => aggListPtr % next
+ end do
+ allocate(aggListPtr % next)
+ aggListPtr => aggListPtr % next
+ end if
+
+ nullify(aggListPtr % next)
+ aggListPtr % procID = inListPtr % procID
+ aggListPtr % blockID = inListPtr % blockID
+ aggListPtr % nlist = inListPtr % nlist
+ allocate(aggListPtr % list(inListPtr % nlist))
+ aggListPtr % list = inListPtr % list
+ aggListPtr % reqID = inListPtr % reqID
+
+ end if
+
+ inListPtr => inListPtr % next
+ end do
+
+
+ inListPtr => recvListArray(haloLayers(i)) % next
+ do while(associated(inListPtr))
+
+ blockAdded = .false.
+ aggListPtr => aggregateRecvList
+ do while(associated(aggListPtr))
+ if(inListPtr % blockID == aggListPtr % blockID) then
+ if(inListPtr % procID .ne. myProcID) then
+ call mpas_merge_integer_arrays(aggListPtr % list, aggListPtr % nlist, inListPtr % list)
+ end if
+ blockAdded = .true.
+ exit
+ end if
+ aggListPtr => aggListPtr % next
+ end do
+
+ if(.not. blockAdded) then
+
+ if (.not. associated(aggregateRecvList)) then
+ allocate(aggregateRecvList)
+ nullify(aggregateRecvList % next)
+ aggListPtr => aggregateRecvList
+ else
+ aggListPtr => aggregateRecvList
+ do while(associated(aggListPtr % next))
+ aggListPtr => aggListPtr % next
+ end do
+
+ allocate(aggListPtr % next)
+ aggListPtr => aggListPtr % next
+ nullify(aggListPtr % next)
+ end if
+
+ aggListPtr % procID = inListPtr % procID
+ aggListPtr % blockID = inListPtr % blockID
+ aggListPtr % nlist = inListPtr % nlist
+ allocate(aggListPtr % list(inListPtr % nlist))
+ aggListPtr % list = inListPtr % list
+ aggListPtr % reqID = inListPtr % reqID
+
+ end if
+
+ inListPtr => inListPtr % next
+ end do
+
+ end do
+
+ if (.not. present(haloLayersIn)) then
+ deallocate(haloLayers)
+ end if
+
+ end subroutine mpas_aggregate_exchange_lists
+
+
+ subroutine mpas_destroy_exchange_list(exchangeList)
+
+ implicit none
+
+ !--- in variables ---!
+ type (exchange_list), pointer :: exchangeList
+
+ !--- local variables ---!
+ type (exchange_list), pointer :: exchangeListPtr
+
+ do while (associated(exchangeList))
+ exchangeListPtr => exchangeList % next
+
+ deallocate(exchangeList % list)
+ deallocate(exchangeList)
+ exchangeList => exchangeListPtr
+ end do
+
+ end subroutine mpas_destroy_exchange_list
+
+
+ subroutine mpas_merge_integer_arrays(mergeArray, nMergeArray, dataToAppend)
+
+ implicit none
+
+ !--- inout variables ---!
+ integer, dimension(:), pointer :: mergeArray
+ integer, intent(inout) :: nMergeArray
+
+ !--- in variables ---!
+ integer, dimension(:), pointer :: dataToAppend
+
+ !--- local variables ---!
+ integer :: nDataToAppend, newSize
+ integer, dimension(nMergeArray) :: mergeArrayCopy
+
+
+ nDataToAppend = size(dataToAppend)
+ newSize = nMergeArray + nDataToAppend
+ mergeArrayCopy = mergeArray
+ deallocate(mergeArray)
+ allocate(mergeArray(newSize))
+ mergeArray(1:nMergeArray) = mergeArrayCopy
+ mergeArray(nMergeArray+1:newSize) = dataToAppend
+ nMergeArray = newSize
+
+ end subroutine mpas_merge_integer_arrays
+
+
end module mpas_dmpar
Added: trunk/mpas/src/framework/mpas_dmpar_types.F
===================================================================
--- trunk/mpas/src/framework/mpas_dmpar_types.F (rev 0)
+++ trunk/mpas/src/framework/mpas_dmpar_types.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -0,0 +1,23 @@
+module mpas_dmpar_types
+
+ use mpas_kind_types
+
+ type dm_info
+ 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
+
+ end type exchange_list
+
+end module mpas_dmpar_types
Modified: trunk/mpas/src/framework/mpas_framework.F
===================================================================
--- trunk/mpas/src/framework/mpas_framework.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/framework/mpas_framework.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -7,6 +7,7 @@
use mpas_configure
use mpas_timer
use mpas_timekeeping
+ use mpas_io
contains
@@ -19,6 +20,9 @@
type (dm_info), pointer :: dminfo
type (domain_type), pointer :: domain
+ integer :: pio_num_iotasks
+ integer :: pio_stride
+
allocate(dminfo)
call mpas_dmpar_init(dminfo)
@@ -28,6 +32,13 @@
call mpas_timekeeping_init(config_calendar_type)
+ pio_num_iotasks = config_pio_num_iotasks
+ pio_stride = config_pio_stride
+ if (pio_num_iotasks == 0) then
+ pio_num_iotasks = domain % dminfo % nprocs
+ end if
+ call MPAS_io_init(dminfo, pio_num_iotasks, pio_stride)
+
end subroutine mpas_framework_init
@@ -38,6 +49,8 @@
type (dm_info), pointer :: dminfo
type (domain_type), pointer :: domain
+ call MPAS_io_finalize()
+
call mpas_deallocate_domain(domain)
call mpas_dmpar_finalize(dminfo)
Modified: trunk/mpas/src/framework/mpas_grid_types.F
===================================================================
--- trunk/mpas/src/framework/mpas_grid_types.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/framework/mpas_grid_types.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -1,6 +1,8 @@
module mpas_grid_types
- use mpas_dmpar
+ use mpas_kind_types
+ use mpas_dmpar_types
+ use mpas_attlist
integer, parameter :: nTimeLevs = 2
@@ -8,6 +10,8 @@
! Derived type describing info for doing I/O specific to a field
type io_info
character (len=1024) :: fieldName
+ character (len=1024) :: units
+ character (len=1024) :: description
integer, dimension(4) :: start
integer, dimension(4) :: count
logical :: input
@@ -19,71 +23,293 @@
! Derived type for storing fields
type field3DReal
+
+ ! Back-pointer to the containing block
type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
real (kind=RKIND), dimension(:,:,:), pointer :: array
- type (io_info), pointer :: ioinfo
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ character (len=64), dimension(3) :: dimNames
+ integer, dimension(3) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
end type field3DReal
! Derived type for storing fields
type field2DReal
+
+ ! Back-pointer to the containing block
type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
real (kind=RKIND), dimension(:,:), pointer :: array
- type (io_info), pointer :: ioinfo
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ character (len=64), dimension(2) :: dimNames
+ integer, dimension(2) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
end type field2DReal
! Derived type for storing fields
type field1DReal
+
+ ! Back-pointer to the containing block
type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
real (kind=RKIND), dimension(:), pointer :: array
- type (io_info), pointer :: ioinfo
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ character (len=64), dimension(1) :: dimNames
+ integer, dimension(1) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
end type field1DReal
! Derived type for storing fields
type field0DReal
+
+ ! Back-pointer to the containing block
type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
real (kind=RKIND) :: scalar
- type (io_info), pointer :: ioinfo
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
end type field0DReal
! Derived type for storing fields
+ type field3DInteger
+
+ ! Back-pointer to the containing block
+ type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
+ integer, dimension(:,:,:), pointer :: array
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ character (len=64), dimension(3) :: dimNames
+ integer, dimension(3) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
+ end type field3DInteger
+
+
+ ! Derived type for storing fields
type field2DInteger
+
+ ! Back-pointer to the containing block
type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
integer, dimension(:,:), pointer :: array
- type (io_info), pointer :: ioinfo
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ character (len=64), dimension(2) :: dimNames
+ integer, dimension(2) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
end type field2DInteger
! Derived type for storing fields
type field1DInteger
+
+ ! Back-pointer to the containing block
type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
integer, dimension(:), pointer :: array
- type (io_info), pointer :: ioinfo
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ character (len=64), dimension(1) :: dimNames
+ integer, dimension(1) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
end type field1DInteger
! Derived type for storing fields
+ type field0DInteger
+
+ ! Back-pointer to the containing block
+ type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
+ integer :: scalar
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
+ end type field0DInteger
+
+
+ ! Derived type for storing fields
type field1DChar
+
+ ! Back-pointer to the containing block
type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
character (len=64), dimension(:), pointer :: array
- type (io_info), pointer :: ioinfo
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ character (len=64), dimension(1) :: dimNames
+ integer, dimension(1) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
end type field1DChar
! Derived type for storing fields
type field0DChar
+
+ ! Back-pointer to the containing block
type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
character (len=64) :: scalar
- type (io_info), pointer :: ioinfo
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=64) :: fieldName
+ character (len=64), dimension(:), pointer :: constituentNames => null()
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (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
end type field0DChar
! Derived type for storing grid meta-data
type mesh_type
+ type (block_type), pointer :: block
+
#include "field_dimensions.inc"
logical :: on_a_sphere
@@ -99,12 +325,17 @@
! Type for storing (possibly architecture specific) information concerning to parallelism
type parallel_info
- type (exchange_list), pointer :: cellsToSend ! List of types describing which cells to send to other blocks
- type (exchange_list), pointer :: cellsToRecv ! List of types describing which cells to receive from other blocks
- type (exchange_list), pointer :: edgesToSend ! List of types describing which edges to send to other blocks
- type (exchange_list), pointer :: edgesToRecv ! List of types describing which edges to receive from other blocks
- type (exchange_list), pointer :: verticesToSend ! List of types describing which vertices to send to other blocks
- type (exchange_list), pointer :: verticesToRecv ! List of types describing which vertices to receive from other blocks
+ 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 (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 (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
end type parallel_info
@@ -113,6 +344,9 @@
#include "block_group_members.inc"
+ integer :: blockID ! Unique global ID number for this block
+ integer :: localBlockID ! Unique local ID number for this block
+
type (domain_type), pointer :: domain
type (parallel_info), pointer :: parinfo
@@ -147,7 +381,7 @@
end subroutine mpas_allocate_domain
- subroutine mpas_allocate_block(b, dom, &
+ subroutine mpas_allocate_block(b, dom, blockID, &
#include "dim_dummy_args.inc"
)
@@ -155,15 +389,33 @@
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
+ b % blockID = blockID
+
nullify(b % prev)
nullify(b % next)
allocate(b % parinfo)
+ allocate(b % parinfo % cellsToSend(nHaloLayers))
+ allocate(b % parinfo % cellsToRecv(nHaloLayers))
+ allocate(b % parinfo % cellsToCopy(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 % 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
+
b % domain => dom
#include "block_allocs.inc"
@@ -201,6 +453,21 @@
integer :: i
+ ! BUG: It seems like we should be deallocating the exchange lists before we
+ ! deallocate the array of head pointers and the parinfo type...
+
+ deallocate(b % parinfo % cellsToSend)
+ deallocate(b % parinfo % cellsToRecv)
+ deallocate(b % parinfo % cellsToCopy)
+
+ deallocate(b % parinfo % edgesToSend)
+ deallocate(b % parinfo % edgesToRecv)
+ deallocate(b % parinfo % edgesToCopy)
+
+ deallocate(b % parinfo % verticesToSend)
+ deallocate(b % parinfo % verticesToRecv)
+ deallocate(b % parinfo % verticesToCopy)
+
deallocate(b % parinfo)
#include "block_deallocs.inc"
@@ -216,4 +483,8 @@
#include "group_shift_level_routines.inc"
+
+#include "field_links.inc"
+
+
end module mpas_grid_types
Added: trunk/mpas/src/framework/mpas_io.F
===================================================================
--- trunk/mpas/src/framework/mpas_io.F (rev 0)
+++ trunk/mpas/src/framework/mpas_io.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -0,0 +1,3475 @@
+module mpas_io
+
+ use mpas_dmpar_types
+ use mpas_dmpar
+
+ use pio
+ use piolib_mod
+ use pionfatt_mod
+ use pio_types
+
+ ! File access modes
+ integer, parameter :: MPAS_IO_READ = 1, &
+ MPAS_IO_WRITE = 2
+
+ ! I/O formats
+ integer, parameter :: MPAS_IO_NETCDF = 3, &
+ MPAS_IO_PNETCDF = 4
+
+ ! Field and attribute types
+ integer, parameter :: MPAS_IO_REAL = 5, &
+ MPAS_IO_DOUBLE = 6, &
+ MPAS_IO_INT = 7, &
+ MPAS_IO_LOGICAL = 8, &
+ MPAS_IO_CHAR = 9
+
+ ! Unlimited / record dimension
+ integer, parameter :: MPAS_IO_UNLIMITED_DIM = -123456
+
+ ! Error codes
+ integer, parameter :: MPAS_IO_NOERR = 0, &
+ MPAS_IO_ERR_INVALID_MODE = -1, &
+ MPAS_IO_ERR_INVALID_FORMAT = -2, &
+ MPAS_IO_ERR_LONG_FILENAME = -3, &
+ MPAS_IO_ERR_UNINIT_HANDLE = -4, &
+ MPAS_IO_ERR_PIO = -5, &
+ MPAS_IO_ERR_DATA_MODE = -6, &
+ MPAS_IO_ERR_NOWRITE = -7, &
+ MPAS_IO_ERR_REDEF_DIM = -8, &
+ MPAS_IO_ERR_REDEF_VAR = -9, &
+ MPAS_IO_ERR_UNDEFINED_DIM = -10, &
+ MPAS_IO_ERR_UNDEFINED_VAR = -11, &
+ MPAS_IO_ERR_REDEF_ATT = -12, &
+ MPAS_IO_ERR_WRONG_ATT_TYPE = -13, &
+ MPAS_IO_ERR_NO_DECOMP = -14, &
+ MPAS_IO_ERR_TWO_UNLIMITED_DIMS = -15, &
+ MPAS_IO_ERR_WRONG_MODE = -16, &
+ MPAS_IO_ERR_NO_UNLIMITED_DIM = -17, &
+ MPAS_IO_ERR_UNIMPLEMENTED = -18
+
+
+ type MPAS_IO_Handle_type
+ logical :: initialized = .false.
+ logical :: data_mode = .false.
+ type (file_desc_t) :: pio_file
+ character (len=1024) :: filename
+ integer :: iomode
+ integer :: ioformat
+ integer :: pio_unlimited_dimid
+ integer (kind=PIO_offset) :: frame_number = 1
+ type (dimlist_type), pointer :: dimlist_head => null()
+ type (dimlist_type), pointer :: dimlist_tail => null()
+ type (fieldlist_type), pointer :: fieldlist_head => null()
+ type (fieldlist_type), pointer :: fieldlist_tail => null()
+ type (attlist_type), pointer :: attlist_head => null()
+ type (attlist_type), pointer :: attlist_tail => null()
+ end type MPAS_IO_Handle_type
+
+
+ interface MPAS_io_get_var
+ module procedure MPAS_io_get_var_int0d
+ module procedure MPAS_io_get_var_int1d
+ module procedure MPAS_io_get_var_int2d
+ module procedure MPAS_io_get_var_int3d
+ module procedure MPAS_io_get_var_int4d
+ module procedure MPAS_io_get_var_real0d
+ module procedure MPAS_io_get_var_real1d
+ module procedure MPAS_io_get_var_real2d
+ module procedure MPAS_io_get_var_real3d
+ module procedure MPAS_io_get_var_real4d
+ module procedure MPAS_io_get_var_char0d
+ end interface MPAS_io_get_var
+
+ interface MPAS_io_put_var
+ module procedure MPAS_io_put_var_int0d
+ module procedure MPAS_io_put_var_int1d
+ module procedure MPAS_io_put_var_int2d
+ module procedure MPAS_io_put_var_int3d
+ module procedure MPAS_io_put_var_int4d
+ module procedure MPAS_io_put_var_real0d
+ module procedure MPAS_io_put_var_real1d
+ module procedure MPAS_io_put_var_real2d
+ module procedure MPAS_io_put_var_real3d
+ module procedure MPAS_io_put_var_real4d
+ module procedure MPAS_io_put_var_char0d
+ end interface MPAS_io_put_var
+
+ interface MPAS_io_get_att
+ module procedure MPAS_io_get_att_int0d
+ module procedure MPAS_io_get_att_int1d
+ module procedure MPAS_io_get_att_real0d
+ module procedure MPAS_io_get_att_real1d
+ module procedure MPAS_io_get_att_text
+ end interface MPAS_io_get_att
+
+ interface MPAS_io_put_att
+ module procedure MPAS_io_put_att_int0d
+ module procedure MPAS_io_put_att_int1d
+ module procedure MPAS_io_put_att_real0d
+ module procedure MPAS_io_put_att_real1d
+ module procedure MPAS_io_put_att_text
+ end interface MPAS_io_put_att
+
+
+ !!!!!!!! PRIVATE !!!!!!!!
+
+! integer, parameter :: ATT_INT = 1
+! integer, parameter :: ATT_INTA = 2
+! integer, parameter :: ATT_REAL = 3
+! integer, parameter :: ATT_REALA = 4
+! integer, parameter :: ATT_TEXT = 5
+
+ type decomphandle_type
+ integer :: field_type
+ integer, dimension(:), pointer :: dims
+ integer, dimension(:), pointer :: indices
+ type (io_desc_t) :: pio_iodesc
+ end type decomphandle_type
+
+ type atthandle_type
+ character (len=1024) :: attName
+ integer :: attType
+ integer :: attValueInt
+ integer, dimension(:), pointer :: attValueIntA => null()
+ real (kind=RKIND) :: attValueReal
+ real (kind=RKIND), dimension(:), pointer :: attValueRealA => null()
+ character (len=1024) :: attValueText
+ end type atthandle_type
+
+ type dimhandle_type
+ character (len=1024) :: dimname
+ logical :: is_unlimited_dim = .false.
+ integer :: dimsize
+ integer :: dimid
+ end type dimhandle_type
+
+ type fieldhandle_type
+ character (len=1024) :: fieldname
+ integer :: fieldid
+ type (Var_desc_t) :: field_desc
+ integer :: field_type
+ logical :: has_unlimited_dim = .false.
+ integer :: ndims
+ type (dimhandle_type), pointer, dimension(:) :: dims
+ type (attlist_type), pointer :: attlist_head => null()
+ type (attlist_type), pointer :: attlist_tail => null()
+ type (decomphandle_type), pointer :: decomp => null()
+ end type fieldhandle_type
+
+ type decomplist_type
+ type (decomphandle_type), pointer :: decomphandle
+ type (decomplist_type), pointer :: next => null()
+ end type decomplist_type
+
+ type attlist_type
+ type (atthandle_type), pointer :: atthandle
+ type (attlist_type), pointer :: next => null()
+ end type attlist_type
+
+ type dimlist_type
+ type (dimhandle_type), pointer :: dimhandle
+ type (dimlist_type), pointer :: next => null()
+ end type dimlist_type
+
+ type fieldlist_type
+ type (fieldhandle_type), pointer :: fieldhandle
+ type (fieldlist_type), pointer :: next => null()
+ end type fieldlist_type
+
+ type (iosystem_desc_t), private, save :: pio_iosystem
+ type (decomplist_type), pointer, private :: decomp_list => null()
+ type (dm_info), private :: local_dminfo
+
+
+ contains
+
+
+ subroutine MPAS_io_init(dminfo, io_task_count, io_task_stride, ierr)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: io_task_count
+ integer, intent(in) :: io_task_stride
+ integer, intent(out), optional :: ierr
+
+! write(0,*) 'Called MPAS_io_init()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ local_dminfo = dminfo
+
+!write(0,*) 'MGD PIO_init'
+ call PIO_init(local_dminfo % my_proc_id, & ! comp_rank
+ local_dminfo % comm, & ! comp_comm
+ io_task_count, & ! num_iotasks
+ 0, & ! num_aggregator
+ io_task_stride, & ! stride
+ PIO_rearr_box, & ! rearr
+ pio_iosystem) ! iosystem
+
+ call pio_seterrorhandling(pio_iosystem, PIO_BCAST_ERROR)
+
+ end subroutine MPAS_io_init
+
+
+ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ierr)
+
+ implicit none
+
+ character (len=*), intent(in) :: filename
+ integer, intent(in) :: mode
+ integer, intent(in) :: ioformat
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_iotype
+ integer :: pio_ierr
+
+! write(0,*) 'Called MPAS_io_open()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+
+ ! Sanity checks
+ if (mode /= MPAS_IO_READ .and. &
+ mode /= MPAS_IO_WRITE) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_INVALID_MODE
+ return
+ end if
+ if (ioformat /= MPAS_IO_NETCDF .and. &
+ ioformat /= MPAS_IO_PNETCDF) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_INVALID_FORMAT
+ return
+ end if
+ if (len(filename) > 1024) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_LONG_FILENAME
+ return
+ end if
+
+ MPAS_io_open % filename = filename
+ MPAS_io_open % iomode = mode
+ MPAS_io_open % ioformat = ioformat
+
+ if (ioformat == MPAS_IO_PNETCDF) then
+ pio_iotype = PIO_iotype_pnetcdf
+ else
+ pio_iotype = PIO_iotype_netcdf
+ end if
+
+ if (mode == MPAS_IO_WRITE) then
+!write(0,*) 'MGD PIO_createfile'
+ pio_ierr = PIO_createfile(pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_64BIT_OFFSET)
+ else
+!write(0,*) 'MGD PIO_openfile'
+ pio_ierr = PIO_openfile(pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_nowrite)
+ endif
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ if (mode == MPAS_IO_READ) then
+!MPAS_io_open % pio_unlimited_dimid = 44
+ pio_ierr = PIO_inquire(MPAS_io_open % pio_file, unlimitedDimID=MPAS_io_open % pio_unlimited_dimid)
+!write(0,*) 'Found unlimited dim ', MPAS_io_open % pio_unlimited_dimid
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+ end if
+
+ MPAS_io_open % initialized = .true.
+
+ return
+
+ end function MPAS_io_open
+
+
+ subroutine MPAS_io_inq_unlimited_dim(handle, dimname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(out) :: dimname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+
+! write(0,*) 'Called MPAS_io_inq_unlimited_dim()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+ if (handle % iomode /= MPAS_IO_READ) then ! We could eventually handle this for write mode, too...
+ if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_MODE
+ return
+ end if
+
+ pio_ierr = PIO_inq_dimname(handle % pio_file, handle % pio_unlimited_dimid, dimname)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NO_UNLIMITED_DIM
+ dimname = ' '
+ return
+ end if
+
+ end subroutine MPAS_io_inq_unlimited_dim
+
+
+ subroutine MPAS_io_inq_dim(handle, dimname, dimsize, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: dimname
+ integer, intent(out) :: dimsize
+ integer, intent(out), optional :: ierr
+
+ type (dimlist_type), pointer :: new_dimlist_node
+ type (dimlist_type), pointer :: dim_cursor
+ integer :: pio_ierr
+
+! write(0,*) 'Called MPAS_io_inq_dim()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+
+ !
+ ! First see if we already have this dimension in our list
+ !
+ dim_cursor => handle % dimlist_head
+ do while (associated(dim_cursor))
+ if (trim(dimname) == trim(dim_cursor % dimhandle % dimname)) then
+ dimsize = dim_cursor % dimhandle % dimsize
+ return
+ end if
+ dim_cursor => dim_cursor % next
+ end do
+
+
+ !
+ ! Otherwise, query the file-level API for information about the dim
+ !
+ allocate(new_dimlist_node)
+ nullify(new_dimlist_node % next)
+ allocate(new_dimlist_node % dimhandle)
+
+ new_dimlist_node % dimhandle % dimname = dimname
+
+ pio_ierr = PIO_inq_dimid(handle % pio_file, trim(dimname), new_dimlist_node % dimhandle % dimid)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_dimlist_node % dimhandle)
+ deallocate(new_dimlist_node)
+ dimsize = -1
+ return
+ end if
+
+ if (new_dimlist_node % dimhandle % dimid == handle % pio_unlimited_dimid) new_dimlist_node % dimhandle % is_unlimited_dim = .true.
+
+ pio_ierr = PIO_inq_dimlen(handle % pio_file, new_dimlist_node % dimhandle % dimid, new_dimlist_node % dimhandle % dimsize)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_dimlist_node % dimhandle)
+ deallocate(new_dimlist_node)
+ dimsize = -1
+ return
+ end if
+
+ ! Keep dimension information for future reference
+ if (.not. associated(handle % dimlist_head)) then
+ handle % dimlist_head => new_dimlist_node
+ end if
+ if (.not. associated(handle % dimlist_tail)) then
+ handle % dimlist_tail => new_dimlist_node
+ else
+ handle % dimlist_tail % next => new_dimlist_node
+ handle % dimlist_tail => handle % dimlist_tail % next
+ end if
+
+ dimsize = new_dimlist_node % dimhandle % dimsize
+
+ end subroutine MPAS_io_inq_dim
+
+
+ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: dimname
+ integer, intent(in) :: dimsize
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (dimlist_type), pointer :: new_dimlist_node
+ type (dimlist_type), pointer :: dim_cursor
+
+! write(0,*) 'Called MPAS_io_def_dim()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+ if (handle % data_mode) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_DATA_MODE
+ return
+ end if
+ if (handle % iomode /= MPAS_IO_WRITE) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NOWRITE
+ return
+ end if
+
+
+ !
+ ! Check that this dimension hasn't already been defined
+ !
+ dim_cursor => handle % dimlist_head
+ do while (associated(dim_cursor))
+ if (trim(dimname) == trim(dim_cursor % dimhandle % dimname)) then
+ if (dimsize /= dim_cursor % dimhandle % dimsize) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_DIM
+ end if
+ return
+ end if
+
+ ! Also, check that the user is not trying to define more than one record dimension
+ if (dimsize == MPAS_IO_UNLIMITED_DIM .and. dim_cursor % dimhandle % is_unlimited_dim) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_TWO_UNLIMITED_DIMS
+ return
+ end if
+ dim_cursor => dim_cursor % next
+ end do
+
+
+ !
+ ! Otherwise, define it
+ !
+ allocate(new_dimlist_node)
+ nullify(new_dimlist_node % next)
+ allocate(new_dimlist_node % dimhandle)
+
+ new_dimlist_node % dimhandle % dimname = dimname
+ new_dimlist_node % dimhandle % dimsize = dimsize
+ if (dimsize == MPAS_IO_UNLIMITED_DIM) then
+ new_dimlist_node % dimhandle % is_unlimited_dim = .true.
+ pio_ierr = PIO_def_dim(handle % pio_file, trim(dimname), PIO_unlimited, new_dimlist_node % dimhandle % dimid)
+ else
+ pio_ierr = PIO_def_dim(handle % pio_file, trim(dimname), dimsize, new_dimlist_node % dimhandle % dimid)
+ end if
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_dimlist_node % dimhandle)
+ deallocate(new_dimlist_node)
+ return
+ end if
+
+ ! Keep dimension information
+ if (.not. associated(handle % dimlist_head)) then
+ handle % dimlist_head => new_dimlist_node
+!write(0,*) 'Assigning head for '//trim(dimname)
+ end if
+ if (.not. associated(handle % dimlist_tail)) then
+ handle % dimlist_tail => new_dimlist_node
+!write(0,*) 'Assigning tail for '//trim(dimname)
+ else
+ handle % dimlist_tail % next => new_dimlist_node
+ handle % dimlist_tail => handle % dimlist_tail % next
+!write(0,*) 'Extending tail for '//trim(dimname)
+ end if
+
+ end subroutine MPAS_io_def_dim
+
+
+ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsizes, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, intent(out), optional :: fieldtype
+ integer, intent(out), optional :: ndims
+ character (len=64), dimension(:), pointer, optional :: dimnames
+ integer, dimension(:), pointer, optional :: dimsizes
+ integer, intent(out), optional :: ierr
+
+ integer :: i
+ type (fieldlist_type), pointer :: new_fieldlist_node
+ type (fieldlist_type), pointer :: field_cursor
+ type (dimlist_type), pointer :: new_dimlist_node
+ type (dimlist_type), pointer :: dim_cursor
+ integer, dimension(:), pointer :: dimids
+ logical :: found
+ integer :: pio_ierr
+
+! write(0,*) 'Called MPAS_io_inq_var()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+
+ !
+ ! See if we already have this variable in our list
+ !
+ found = .false.
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+!write(0,*) 'Already found variable in fieldlist'
+ found = .true.
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+
+ !
+ ! Otherwise, inquire through the file-level API and add it to the list
+ !
+ if (.not. found) then
+
+ allocate(new_fieldlist_node)
+ nullify(new_fieldlist_node % next)
+ allocate(new_fieldlist_node % fieldhandle)
+
+ new_fieldlist_node % fieldhandle % fieldname = fieldname
+
+ ! Get variable ID
+ pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % fieldid)
+ pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % field_desc)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_fieldlist_node % fieldhandle)
+ deallocate(new_fieldlist_node)
+ return
+ end if
+!write(0,*) 'Inquired about variable ID', new_fieldlist_node % fieldhandle % fieldid
+
+ ! Get field type
+ pio_ierr = PIO_inq_vartype(handle % pio_file, new_fieldlist_node % fieldhandle % fieldid, new_fieldlist_node % fieldhandle % field_type)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_fieldlist_node % fieldhandle)
+ deallocate(new_fieldlist_node)
+ return
+ end if
+!write(0,*) 'Inquired about variable type', new_fieldlist_node % fieldhandle % field_type
+
+ ! Convert to MPAS type
+ if (new_fieldlist_node % fieldhandle % field_type == PIO_double) then
+ new_fieldlist_node % fieldhandle % field_type = MPAS_IO_DOUBLE
+ else if (new_fieldlist_node % fieldhandle % field_type == PIO_real) then
+ new_fieldlist_node % fieldhandle % field_type = MPAS_IO_REAL
+ else if (new_fieldlist_node % fieldhandle % field_type == PIO_int) then
+ new_fieldlist_node % fieldhandle % field_type = MPAS_IO_INT
+ else if (new_fieldlist_node % fieldhandle % field_type == PIO_char) then
+ new_fieldlist_node % fieldhandle % field_type = MPAS_IO_CHAR
+!!!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!!
+ end if
+
+ ! Get number of dimensions
+ pio_ierr = PIO_inq_varndims(handle % pio_file, new_fieldlist_node % fieldhandle % fieldid, new_fieldlist_node % fieldhandle % ndims)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_fieldlist_node % fieldhandle)
+ deallocate(new_fieldlist_node)
+ return
+ end if
+!write(0,*) 'Inquired about number of dimensions ', new_fieldlist_node % fieldhandle % ndims
+
+ allocate(dimids(new_fieldlist_node % fieldhandle % ndims))
+
+ ! Get dimension IDs
+ if (new_fieldlist_node % fieldhandle % ndims > 0) then
+ pio_ierr = PIO_inq_vardimid(handle % pio_file, new_fieldlist_node % fieldhandle % fieldid, dimids)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_fieldlist_node % fieldhandle)
+ deallocate(new_fieldlist_node)
+ deallocate(dimids)
+ return
+ end if
+!write(0,*) 'Inquired about dimension IDs ', dimids
+ end if
+
+ allocate(new_fieldlist_node % fieldhandle % dims(new_fieldlist_node % fieldhandle % ndims))
+
+ ! Get information about dimensions
+ do i=1,new_fieldlist_node % fieldhandle % ndims
+ new_fieldlist_node % fieldhandle % dims(i) % dimid = dimids(i)
+ if (dimids(i) == handle % pio_unlimited_dimid) then
+ new_fieldlist_node % fieldhandle % dims(i) % is_unlimited_dim = .true.
+ new_fieldlist_node % fieldhandle % has_unlimited_dim = .true.
+ end if
+
+ pio_ierr = PIO_inq_dimlen(handle % pio_file, dimids(i), new_fieldlist_node % fieldhandle % dims(i) % dimsize)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_fieldlist_node % fieldhandle)
+ deallocate(new_fieldlist_node)
+ deallocate(dimids)
+ return
+ end if
+!write(0,*) 'Inquired about dimension size ', new_fieldlist_node % fieldhandle % dims(i) % dimsize
+
+ pio_ierr = PIO_inq_dimname(handle % pio_file, dimids(i), new_fieldlist_node % fieldhandle % dims(i) % dimname)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ deallocate(new_fieldlist_node % fieldhandle)
+ deallocate(new_fieldlist_node)
+ deallocate(dimids)
+ return
+ end if
+!write(0,*) 'Inquired about dimension name ', trim(new_fieldlist_node % fieldhandle % dims(i) % dimname)
+
+ end do
+
+ deallocate(dimids)
+
+ ! Keep variable information for future reference
+ if (.not. associated(handle % fieldlist_head)) then
+ handle % fieldlist_head => new_fieldlist_node
+!write(0,*) 'Assigning head for '//trim(fieldname)
+ end if
+ if (.not. associated(handle % fieldlist_tail)) then
+ handle % fieldlist_tail => new_fieldlist_node
+!write(0,*) 'Assigning tail for '//trim(fieldname)
+ else
+ handle % fieldlist_tail % next => new_fieldlist_node
+ handle % fieldlist_tail => handle % fieldlist_tail % next
+!write(0,*) 'Extending tail for '//trim(fieldname)
+ end if
+
+ ! Keep dimension information for any new dimensions that were encountered
+ do i=1,new_fieldlist_node % fieldhandle % ndims
+ found = .false.
+ dim_cursor => handle % dimlist_head
+ do while (associated(dim_cursor))
+ if (trim(dim_cursor % dimhandle % dimname) == trim(new_fieldlist_node % fieldhandle % dims(i) % dimname)) then
+!write(0,*) 'Already have dimension '//trim(new_fieldlist_node % fieldhandle % dims(i) % dimname)//' in our list...'
+ found = .true.
+ exit
+ end if
+ dim_cursor => dim_cursor % next
+ end do
+
+ if (.not. found) then
+ allocate(new_dimlist_node)
+ nullify(new_dimlist_node % next)
+ allocate(new_dimlist_node % dimhandle)
+ new_dimlist_node % dimhandle = new_fieldlist_node % fieldhandle % dims(i)
+ if (.not. associated(handle % dimlist_head)) then
+ handle % dimlist_head => new_dimlist_node
+!write(0,*) 'Assigning head for '//trim(new_dimlist_node % dimhandle % dimname)
+ end if
+ if (.not. associated(handle % dimlist_tail)) then
+ handle % dimlist_tail => new_dimlist_node
+!write(0,*) 'Assigning tail for '//trim(new_dimlist_node % dimhandle % dimname)
+ else
+ handle % dimlist_tail % next => new_dimlist_node
+ handle % dimlist_tail => handle % dimlist_tail % next
+!write(0,*) 'Extending tail for '//trim(new_dimlist_node % dimhandle % dimname)
+ end if
+ end if
+ end do
+ field_cursor => new_fieldlist_node
+ end if
+
+
+ !
+ ! Set output arguments
+ !
+ if (present(fieldtype)) fieldtype = field_cursor % fieldhandle % field_type
+ if (present(ndims)) ndims = field_cursor % fieldhandle % ndims
+ if (present(dimnames)) then
+ allocate(dimnames(field_cursor % fieldhandle % ndims))
+ do i=1,field_cursor % fieldhandle % ndims
+ dimnames(i) = field_cursor % fieldhandle % dims(i) % dimname
+ end do
+ end if
+ if (present(dimsizes)) then
+ allocate(dimsizes(field_cursor % fieldhandle % ndims))
+ do i=1,field_cursor % fieldhandle % ndims
+ dimsizes(i) = field_cursor % fieldhandle % dims(i) % dimsize
+ end do
+ end if
+
+ end subroutine MPAS_io_inq_var
+
+
+ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, intent(in) :: fieldtype
+ character (len=64), dimension(:), intent(in) :: dimnames
+ integer, intent(out), optional :: ierr
+
+ integer :: i
+ integer :: pio_ierr
+ integer :: pio_type
+ integer :: ndims
+ type (fieldlist_type), pointer :: new_fieldlist_node
+ type (fieldlist_type), pointer :: field_cursor
+ type (dimlist_type), pointer :: dim_cursor
+ integer, dimension(:), pointer :: dimids
+
+! write(0,*) 'Called MPAS_io_def_var()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+ if (handle % data_mode) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_DATA_MODE
+ return
+ end if
+ if (handle % iomode /= MPAS_IO_WRITE) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NOWRITE
+ return
+ end if
+
+
+ !
+ ! Check whether this field has already been defined
+ !
+ ndims = size(dimnames)
+!write(0,*) 'Defining variable with ',ndims,' dimensions'
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ if (ndims /= field_cursor % fieldhandle % ndims) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_VAR
+! write(0,*) 'Error: Field '//trim(fieldname)//' previously defined with conflicting number of dimensions: ', &
+! ndims, field_cursor % fieldhandle % ndims
+ end if
+ if (fieldtype /= field_cursor % fieldhandle % field_type) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_VAR
+! write(0,*) 'Error: Field '//trim(fieldname)//' previously defined with conflicting type: ', &
+! fieldtype, field_cursor % fieldhandle % field_type
+ end if
+ return
+ end if
+ field_cursor => field_cursor % next
+ end do
+
+ !
+ ! Otherwise, define it
+ !
+ allocate(new_fieldlist_node)
+ nullify(new_fieldlist_node % next)
+ allocate(new_fieldlist_node % fieldhandle)
+
+ new_fieldlist_node % fieldhandle % fieldname = fieldname
+ new_fieldlist_node % fieldhandle % field_type = fieldtype
+ new_fieldlist_node % fieldhandle % ndims = ndims
+
+ allocate(dimids(ndims))
+ allocate(new_fieldlist_node % fieldhandle % dims(ndims))
+ do i = 1, ndims
+ dim_cursor => handle % dimlist_head
+ do while (associated(dim_cursor))
+ if (trim(dimnames(i)) == trim(dim_cursor % dimhandle % dimname)) then
+ exit
+ end if
+ dim_cursor => dim_cursor % next
+ end do
+ if (associated(dim_cursor)) then
+ dimids(i) = dim_cursor % dimhandle % dimid
+ if (dim_cursor % dimhandle % is_unlimited_dim) new_fieldlist_node % fieldhandle % has_unlimited_dim = .true.
+ new_fieldlist_node % fieldhandle % dims(i) = dim_cursor % dimhandle
+!write(0,*) 'Found dimension '//trim(new_fieldlist_node % fieldhandle % dims(i) % dimname)//' for field '//trim(fieldname)
+ else
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_DIM
+ deallocate(new_fieldlist_node % fieldhandle % dims)
+ deallocate(new_fieldlist_node % fieldhandle)
+ deallocate(new_fieldlist_node)
+ deallocate(dimids)
+ return
+! write(0,*) 'Error finding dimension '//trim(dimnames(i))//' for field '//trim(fieldname)
+ end if
+ end do
+
+ ! Convert from MPAS type
+ if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_DOUBLE) then
+ pio_type = PIO_double
+ else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_REAL) then
+ pio_type = PIO_real
+ else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_INT) then
+ pio_type = PIO_int
+ else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_CHAR) then
+ pio_type = PIO_char
+!!!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!!
+ end if
+
+ if (ndims == 0) then
+ pio_ierr = PIO_def_var(handle % pio_file, trim(fieldname), pio_type, new_fieldlist_node % fieldhandle % field_desc)
+ else
+ pio_ierr = PIO_def_var(handle % pio_file, trim(fieldname), pio_type, dimids, new_fieldlist_node % fieldhandle % field_desc)
+ end if
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Get the varid for use by put_att routines
+ pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % fieldid)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ deallocate(dimids)
+
+ ! Keep variable information for future use
+ if (.not. associated(handle % fieldlist_head)) then
+ handle % fieldlist_head => new_fieldlist_node
+!write(0,*) 'Assigning head for '//trim(fieldname)
+ end if
+ if (.not. associated(handle % fieldlist_tail)) then
+ handle % fieldlist_tail => new_fieldlist_node
+!write(0,*) 'Assigning tail for '//trim(fieldname)
+ else
+ handle % fieldlist_tail % next => new_fieldlist_node
+ handle % fieldlist_tail => handle % fieldlist_tail % next
+!write(0,*) 'Extending tail for '//trim(fieldname)
+ end if
+
+ end subroutine MPAS_io_def_var
+
+
+ subroutine MPAS_io_get_var_indices(handle, fieldname, indices, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(in) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:), pointer :: indices
+ integer, intent(out), optional :: ierr
+
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_indices()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+
+ !
+ ! Check whether the field has been defined
+ !
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+!write(0,*) trim(fieldname), ' has been defined'
+
+ if (.not. associated(field_cursor % fieldhandle % decomp)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NO_DECOMP
+ return
+ end if
+
+ allocate(indices(size(field_cursor % fieldhandle % decomp % indices)))
+ indices(:) = field_cursor % fieldhandle % decomp % indices(:)
+
+ end subroutine MPAS_io_get_var_indices
+
+
+ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(in) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:), intent(in) :: indices
+ integer, intent(out), optional :: ierr
+
+ type (fieldlist_type), pointer :: field_cursor
+ integer :: pio_type
+ integer :: ndims, pd
+ integer :: i, i1, i2, i3, i4, i5, indx
+ integer, dimension(:), pointer :: dimlist, compdof
+ type (decomplist_type), pointer :: decomp_cursor, new_decomp
+
+! write(0,*) 'Called MPAS_io_set_var_indices()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+! write(0,*) 'Assigning ', size(indices), ' indices for ', trim(fieldname)
+
+
+ !
+ ! Check whether the field has been defined
+ !
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+!write(0,*) trim(fieldname), ' has been defined'
+
+ !
+ ! If this is a scalar field, just return
+ !
+ if (field_cursor % fieldhandle % ndims == 0 .or. &
+ (field_cursor % fieldhandle % ndims == 1 .and. field_cursor % fieldhandle % has_unlimited_dim) .or. &
+ field_cursor % fieldhandle % field_type == MPAS_IO_CHAR) then
+!write(0,*) 'No need to create a decomposition for a 0d field...'
+ return
+ end if
+
+
+ !
+ ! Check whether a suitable decomposition already exists
+ !
+ decomp_cursor => decomp_list
+!if (.not. associated(decomp_cursor)) write(0,*) 'No existing decompositions to check...'
+ DECOMP_LOOP: do while (associated(decomp_cursor))
+ if (decomp_cursor % decomphandle % field_type == field_cursor % fieldhandle % field_type) then
+ if (size(decomp_cursor % decomphandle % dims) == field_cursor % fieldhandle % ndims) then
+!write(0,*) 'Number of dimensions matches...'
+ do i=1,field_cursor % fieldhandle % ndims
+!write(0,*) 'Checking dimension ', decomp_cursor % decomphandle % dims(i), field_cursor % fieldhandle % dims(i) % dimsize
+ if (decomp_cursor % decomphandle % dims(i) /= field_cursor % fieldhandle % dims(i) % dimsize) then
+ decomp_cursor => decomp_cursor % next
+ cycle DECOMP_LOOP
+ end if
+ end do
+
+ if (size(decomp_cursor % decomphandle % indices) /= size(indices)) then
+!write(0,*) 'We do not have the same number of indices in this decomposition...'
+ decomp_cursor => decomp_cursor % next
+ cycle DECOMP_LOOP
+ end if
+
+ do i=1,size(decomp_cursor % decomphandle % indices)
+ if (indices(i) /= decomp_cursor % decomphandle % indices(i)) then
+!write(0,*) 'One of the indices does not match... ', i
+ decomp_cursor => decomp_cursor % next
+ cycle DECOMP_LOOP
+ end if
+ end do
+
+ ! OK, we have a match... just use this decomposition for the field and return
+ field_cursor % fieldhandle % decomp => decomp_cursor % decomphandle
+!write(0,*) 'Found a matching decomposition that we can use'
+ return
+ else if ((size(decomp_cursor % decomphandle % dims) == field_cursor % fieldhandle % ndims - 1) &
+ .and. field_cursor % fieldhandle % has_unlimited_dim &
+ ) then
+!write(0,*) 'Number of non-record dimensions matches...'
+ do i=1,field_cursor % fieldhandle % ndims
+ if (field_cursor % fieldhandle % dims(i) % is_unlimited_dim) cycle
+!write(0,*) 'Checking dimension ', decomp_cursor % decomphandle % dims(i), field_cursor % fieldhandle % dims(i) % dimsize
+ if (decomp_cursor % decomphandle % dims(i) /= field_cursor % fieldhandle % dims(i) % dimsize) then
+ decomp_cursor => decomp_cursor % next
+ cycle DECOMP_LOOP
+ end if
+ end do
+
+ ! Type and dimensions match... what about indices?
+
+ ! OK, we have a match... just use this decomposition for the field and return
+ field_cursor % fieldhandle % decomp => decomp_cursor % decomphandle
+!write(0,*) 'Found a matching decomposition that we can use (aside from record dimension)'
+ return
+ end if
+ end if
+ decomp_cursor => decomp_cursor % next
+ end do DECOMP_LOOP
+
+!write(0,*) 'Creating a new decomposition'
+
+
+ !
+ ! Otherwise, we need to create a new decomposition
+ !
+ ndims = field_cursor % fieldhandle % ndims
+ if (field_cursor % fieldhandle % has_unlimited_dim) ndims = ndims - 1
+
+
+ allocate(new_decomp)
+ nullify(new_decomp % next)
+ allocate(new_decomp % decomphandle)
+ allocate(new_decomp % decomphandle % dims(ndims))
+ allocate(new_decomp % decomphandle % indices(size(indices)))
+
+ new_decomp % decomphandle % field_type = field_cursor % fieldhandle % field_type
+ new_decomp % decomphandle % indices(:) = indices(:)
+
+ ! Convert from MPAS type
+ if (field_cursor % fieldhandle % field_type == MPAS_IO_DOUBLE) then
+ pio_type = PIO_double
+ else if (field_cursor % fieldhandle % field_type == MPAS_IO_REAL) then
+ pio_type = PIO_real
+ else if (field_cursor % fieldhandle % field_type == MPAS_IO_INT) then
+ pio_type = PIO_int
+ else if (field_cursor % fieldhandle % field_type == MPAS_IO_CHAR) then
+ pio_type = PIO_char
+!!!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!!
+ end if
+
+ allocate(dimlist(ndims))
+
+ pd = 1
+ do i=1,ndims-1
+ dimlist(i) = field_cursor % fieldhandle % dims(i) % dimsize
+ new_decomp % decomphandle % dims(i) = dimlist(i)
+ pd = pd * dimlist(i)
+ end do
+ new_decomp % decomphandle % dims(ndims) = field_cursor % fieldhandle % dims(ndims) % dimsize
+ dimlist(ndims) = size(indices)
+ pd = pd * dimlist(ndims)
+
+ allocate(compdof(pd))
+
+ indx = 1
+ if (ndims == 5) then
+ do i5=1,dimlist(5)
+ do i4=1,dimlist(4)
+ do i3=1,dimlist(3)
+ do i2=1,dimlist(2)
+ do i1=1,dimlist(1)
+ compdof(indx) = i1 &
+ + (i2-1)*dimlist(1) &
+ + (i3-1)*dimlist(2)*dimlist(1) &
+ + (i4-1)*dimlist(3)*dimlist(2)*dimlist(1) &
+ + (indices(i5)-1)*dimlist(4)*dimlist(3)*dimlist(2)*dimlist(1)
+ indx = indx + 1
+ end do
+ end do
+ end do
+ end do
+ end do
+ else if (ndims == 4) then
+ do i4=1,dimlist(4)
+ do i3=1,dimlist(3)
+ do i2=1,dimlist(2)
+ do i1=1,dimlist(1)
+ compdof(indx) = i1 &
+ + (i2-1)*dimlist(1) &
+ + (i3-1)*dimlist(2)*dimlist(1) &
+ + (indices(i4)-1)*dimlist(3)*dimlist(2)*dimlist(1)
+ indx = indx + 1
+ end do
+ end do
+ end do
+ end do
+ else if (ndims == 3) then
+ do i3=1,dimlist(3)
+ do i2=1,dimlist(2)
+ do i1=1,dimlist(1)
+ compdof(indx) = i1 + (i2-1)*dimlist(1) + (indices(i3)-1)*dimlist(2)*dimlist(1)
+ indx = indx + 1
+ end do
+ end do
+ end do
+ else if (ndims == 2) then
+ do i2=1,dimlist(2)
+ do i1=1,dimlist(1)
+ compdof(indx) = i1 + (indices(i2)-1)*dimlist(1)
+ indx = indx + 1
+ end do
+ end do
+ else if (ndims == 1) then
+ do i1=1,dimlist(1)
+ compdof(indx) = indices(i1)
+ indx = indx + 1
+ end do
+ end if
+
+ dimlist(ndims) = field_cursor % fieldhandle % dims(ndims) % dimsize
+ call PIO_initdecomp(pio_iosystem, pio_type, dimlist, compdof, new_decomp % decomphandle % pio_iodesc)
+
+ ! Add new decomposition to the list
+ if (.not. associated(decomp_list)) then
+ decomp_list => new_decomp
+!write(0,*) 'Adding first item to the decomp_list'
+ else
+ new_decomp % next => decomp_list
+ decomp_list => new_decomp
+!write(0,*) 'Adding new decomp to the head of the list'
+ end if
+
+!write(0,*) 'Setting decomp in fieldhandle'
+ field_cursor % fieldhandle % decomp => new_decomp % decomphandle
+
+ deallocate(compdof)
+ deallocate(dimlist)
+!write(0,*) 'All finished.'
+
+ end subroutine MPAS_io_set_var_indices
+
+
+ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, &
+ realVal, realArray1d, realArray2d, realArray3d, realArray4d, &
+ charVal, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, intent(out), optional :: intVal
+ integer, dimension(:), intent(out), optional :: intArray1d
+ integer, dimension(:,:), intent(out), optional :: intArray2d
+ integer, dimension(:,:,:), intent(out), optional :: intArray3d
+ integer, dimension(:,:,:,:), intent(out), optional :: intArray4d
+ real (kind=RKIND), intent(out), optional :: realVal
+ real (kind=RKIND), dimension(:), intent(out), optional :: realArray1d
+ real (kind=RKIND), dimension(:,:), intent(out), optional :: realArray2d
+ real (kind=RKIND), dimension(:,:,:), intent(out), optional :: realArray3d
+ real (kind=RKIND), dimension(:,:,:,:), intent(out), optional :: realArray4d
+ character (len=*), intent(out), optional :: charVal
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer, dimension(1) :: start1
+ integer, dimension(1) :: count1
+ integer, dimension(2) :: start2
+ integer, dimension(2) :: count2
+ character (len=1024), dimension(1) :: tempchar
+ type (fieldlist_type), pointer :: field_cursor
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+! write(0,*) 'Reading ', trim(fieldname)
+
+ !
+ ! Check whether the field has been defined
+ !
+! write(0,*) 'Checking if field is define'
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+
+
+ !
+ ! Check that we have a decomposition for this field
+ !
+! write(0,*) 'Checking for decomposition'
+ if (.not.present(intVal) .and. .not.present(realVal) .and. .not.present(charVal)) then
+ if (.not. associated(field_cursor % fieldhandle % decomp)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NO_DECOMP
+ return
+ end if
+ end if
+
+!!!! Assume array was already allocated by the user
+
+! write(0,*) 'Checking for unlimited dim'
+ if (field_cursor % fieldhandle % has_unlimited_dim) then
+ call PIO_setframe(field_cursor % fieldhandle % field_desc, handle % frame_number)
+ start1(1) = handle % frame_number
+ count1(1) = 1
+
+ start2(1) = 1
+ start2(2) = handle % frame_number
+ count2(2) = 1
+ end if
+
+! write(0,*) 'Checking for real, int, char, etc'
+ if (present(realVal)) then
+! write (0,*) ' value is real'
+ if (field_cursor % fieldhandle % has_unlimited_dim) then
+ pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal)
+ else
+ pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal)
+ end if
+ else if (present(intVal)) then
+! write (0,*) ' value is int'
+ if (field_cursor % fieldhandle % has_unlimited_dim) then
+ pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, intVal)
+ else
+ pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, intVal)
+ end if
+ else if (present(charVal)) then
+! write (0,*) ' value is char'
+ if (field_cursor % fieldhandle % has_unlimited_dim) then
+ count2(1) = field_cursor % fieldhandle % dims(1) % dimsize
+ pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar)
+ charVal(1:count2(1)) = tempchar(1)(1:count2(1))
+ else
+ pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, charVal)
+ end if
+ else if (present(realArray1d)) then
+! write (0,*) ' value is real1'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray1d, pio_ierr)
+ else if (present(realArray2d)) then
+! write (0,*) ' value is real2'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray2d, pio_ierr)
+ else if (present(realArray3d)) then
+! write (0,*) ' value is real3'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray3d, pio_ierr)
+ else if (present(realArray4d)) then
+! write (0,*) ' value is real4'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray4d, pio_ierr)
+ else if (present(intArray1d)) then
+! write (0,*) ' value is int1'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ intArray1d, pio_ierr)
+ else if (present(intArray2d)) then
+! write (0,*) ' value is int2'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ intArray2d, pio_ierr)
+ else if (present(intArray3d)) then
+! write (0,*) ' value is int3'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ intArray3d, pio_ierr)
+ else if (present(intArray4d)) then
+! write (0,*) ' value is int4'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ intArray4d, pio_ierr)
+ end if
+
+! write (0,*) 'Checking for error'
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ end subroutine MPAS_io_get_var_generic
+
+
+ subroutine MPAS_io_get_var_int0d(handle, fieldname, val, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, intent(out) :: val
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer, dimension(1) :: start
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_int0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, intVal=val, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_int0d
+
+
+ subroutine MPAS_io_get_var_int1d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_int1d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, intArray1d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_int1d
+
+
+ subroutine MPAS_io_get_var_int2d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_int2d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, intArray2d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_int2d
+
+
+ subroutine MPAS_io_get_var_int3d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:,:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_int3d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, intArray3d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_int3d
+
+
+ subroutine MPAS_io_get_var_int4d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:,:,:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_int4d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, intArray4d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_int4d
+
+
+ subroutine MPAS_io_get_var_real0d(handle, fieldname, val, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), intent(out) :: val
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer, dimension(1) :: start
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_real0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, realVal=val, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_real0d
+
+
+ subroutine MPAS_io_get_var_real1d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_real1d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, realArray1d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_real1d
+
+
+ subroutine MPAS_io_get_var_real2d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_real2d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, realArray2d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_real2d
+
+
+ subroutine MPAS_io_get_var_real3d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_real3d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, realArray3d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_real3d
+
+
+ subroutine MPAS_io_get_var_real4d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_real4d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, realArray4d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_real4d
+
+
+ subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ character (len=*), intent(out) :: val
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_char0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, charVal=val, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_char0d
+
+
+ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, &
+ realVal, realArray1d, realArray2d, realArray3d, realArray4d, &
+ charVal, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, intent(in), optional :: intVal
+ integer, dimension(:), intent(in), optional :: intArray1d
+ integer, dimension(:,:), intent(in), optional :: intArray2d
+ integer, dimension(:,:,:), intent(in), optional :: intArray3d
+ integer, dimension(:,:,:,:), intent(in), optional :: intArray4d
+ real (kind=RKIND), intent(in), optional :: realVal
+ real (kind=RKIND), dimension(:), intent(in), optional :: realArray1d
+ real (kind=RKIND), dimension(:,:), intent(in), optional :: realArray2d
+ real (kind=RKIND), dimension(:,:,:), intent(in), optional :: realArray3d
+ real (kind=RKIND), dimension(:,:,:,:), intent(in), optional :: realArray4d
+ character (len=*), intent(in), optional :: charVal
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer, dimension(1) :: start1
+ integer, dimension(1) :: count1
+ integer, dimension(2) :: start2
+ integer, dimension(2) :: count2
+ type (fieldlist_type), pointer :: field_cursor
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+ if (.not. handle % data_mode) then
+ handle % data_mode = .true.
+
+ pio_ierr = PIO_enddef(handle % pio_file)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+ end if
+
+! write(0,*) 'Writing ', trim(fieldname)
+
+
+ !
+ ! Check whether the field has been defined
+ !
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+
+
+ !
+ ! Check that we have a decomposition for this field
+ !
+ if (.not.present(intVal) .and. .not.present(realVal) .and. .not.present(charVal)) then
+ if (.not. associated(field_cursor % fieldhandle % decomp)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NO_DECOMP
+ return
+ end if
+ end if
+
+ if (field_cursor % fieldhandle % has_unlimited_dim) then
+ call PIO_setframe(field_cursor % fieldhandle % field_desc, handle % frame_number)
+ start1(1) = handle % frame_number
+ count1(1) = 1
+
+ start2(1) = 1
+ start2(2) = handle % frame_number
+ count2(2) = 1
+ else if (handle % frame_number > 1) then
+ if(present(ierr)) ierr = MPAS_IO_NOERR
+ return
+ end if
+
+ if (present(realVal)) then
+ if (field_cursor % fieldhandle % has_unlimited_dim) then
+ pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal)
+ else
+ pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal)
+ end if
+ else if (present(intVal)) then
+ if (field_cursor % fieldhandle % has_unlimited_dim) then
+ pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, intVal)
+ else
+ pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, intVal)
+ end if
+ else if (present(charVal)) then
+ if (field_cursor % fieldhandle % has_unlimited_dim) then
+ count2(1) = field_cursor % fieldhandle % dims(1) % dimsize
+ pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, (/charVal/))
+ else
+ pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, charVal)
+ end if
+ else if (present(realArray1d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray1d, pio_ierr)
+ else if (present(realArray2d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray2d, pio_ierr)
+ else if (present(realArray3d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray3d, pio_ierr)
+ else if (present(realArray4d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray4d, pio_ierr)
+ else if (present(intArray1d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ intArray1d, pio_ierr)
+ else if (present(intArray2d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ intArray2d, pio_ierr)
+ else if (present(intArray3d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ intArray3d, pio_ierr)
+ else if (present(intArray4d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ intArray4d, pio_ierr)
+ end if
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ end subroutine MPAS_io_put_var_generic
+
+
+ subroutine MPAS_io_put_var_int0d(handle, fieldname, val, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, intent(in) :: val
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer, dimension(1) :: start
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_int0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, intVal=val, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_int0d
+
+
+ subroutine MPAS_io_put_var_int1d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_int1d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, intArray1d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_int1d
+
+
+ subroutine MPAS_io_put_var_int2d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_int2d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, intArray2d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_int2d
+
+
+ subroutine MPAS_io_put_var_int3d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:,:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_int3d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, intArray3d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_int3d
+
+
+ subroutine MPAS_io_put_var_int4d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ integer, dimension(:,:,:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_int4d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, intArray4d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_int4d
+
+
+ subroutine MPAS_io_put_var_real0d(handle, fieldname, val, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), intent(in) :: val
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer, dimension(1) :: start
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_real0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, realVal=val, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_real0d
+
+
+ subroutine MPAS_io_put_var_real1d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_real1d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, realArray1d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_real1d
+
+
+ subroutine MPAS_io_put_var_real2d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_real2d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, realArray2d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_real2d
+
+
+ subroutine MPAS_io_put_var_real3d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_real3d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, realArray3d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_real3d
+
+
+ subroutine MPAS_io_put_var_real4d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_real4d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, realArray4d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_real4d
+
+
+ subroutine MPAS_io_put_var_char0d(handle, fieldname, val, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ character (len=*), intent(in) :: val
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_char0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, charVal=val, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_char0d
+
+
+ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ integer, intent(out) :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ integer :: xtype, len
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: att_cursor, new_att_node
+
+! write(0,*) 'Called MPAS_io_get_att_int0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+
+ ! Check whether we have this attribute cached
+ att_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_INT) then
+!write(0,*) 'Using cached attribute'
+ attValue = att_cursor % atthandle % attValueInt
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ else
+
+ ! Check whether we have this attribute cached
+ att_cursor => handle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_INT) then
+!write(0,*) 'Using cached attribute'
+ attValue = att_cursor % atthandle % attValueInt
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ varid = PIO_global
+ end if
+
+ ! Query attribute value
+ pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+ if (xtype /= PIO_int) then
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ return
+ end if
+
+ pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Keep attribute for future reference
+ allocate(new_att_node)
+ nullify(new_att_node % next)
+ allocate(new_att_node % atthandle)
+ new_att_node % atthandle % attName = attName
+ new_att_node % atthandle % attType = ATT_INT
+ new_att_node % atthandle % attValueInt = attValue
+
+ if (present(fieldname)) then
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_att_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ else
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ handle % attlist_tail % next => new_att_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ end if
+
+ end subroutine MPAS_io_get_att_int0d
+
+
+ subroutine MPAS_io_get_att_int1d(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ integer, dimension(:), pointer :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ integer :: xtype, len, attlen
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: att_cursor, new_att_node
+
+! write(0,*) 'Called MPAS_io_get_att_int1d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+
+ ! Check whether we have this attribute cached
+ att_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_INTA) then
+!write(0,*) 'Using cached attribute'
+ allocate(attValue(size(att_cursor % atthandle % attValueIntA)))
+ attValue = att_cursor % atthandle % attValueIntA
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ else
+
+ ! Check whether we have this attribute cached
+ att_cursor => handle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_INTA) then
+!write(0,*) 'Using cached attribute'
+ allocate(attValue(size(att_cursor % atthandle % attValueIntA)))
+ attValue = att_cursor % atthandle % attValueIntA
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ varid = PIO_global
+ end if
+
+ ! Query attribute value
+ pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ if (xtype /= PIO_int) then
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ return
+ end if
+
+ pio_ierr = PIO_inq_attlen(handle % pio_file, varid, attName, attlen)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ allocate(attValue(attlen))
+ pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Keep attribute for future reference
+ allocate(new_att_node)
+ nullify(new_att_node % next)
+ allocate(new_att_node % atthandle)
+ new_att_node % atthandle % attName = attName
+ new_att_node % atthandle % attType = ATT_INTA
+ allocate(new_att_node % atthandle % attValueIntA(attlen))
+ new_att_node % atthandle % attValueIntA = attValue
+
+ if (present(fieldname)) then
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_att_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ else
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ handle % attlist_tail % next => new_att_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ end if
+
+ end subroutine MPAS_io_get_att_int1d
+
+
+ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), intent(out) :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ integer :: xtype, len
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: att_cursor, new_att_node
+
+! write(0,*) 'Called MPAS_io_get_att_real0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+
+ ! Check whether we have this attribute cached
+ att_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_REAL) then
+!write(0,*) 'Using cached attribute'
+ attValue = att_cursor % atthandle % attValueReal
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ else
+
+ ! Check whether we have this attribute cached
+ att_cursor => handle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_REAL) then
+!write(0,*) 'Using cached attribute'
+ attValue = att_cursor % atthandle % attValueReal
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ varid = PIO_global
+ end if
+
+ ! Query attribute value
+ pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+ if (xtype /= PIO_double) then
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ return
+ end if
+
+ pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Keep attribute for future reference
+ allocate(new_att_node)
+ nullify(new_att_node % next)
+ allocate(new_att_node % atthandle)
+ new_att_node % atthandle % attName = attName
+ new_att_node % atthandle % attType = ATT_REAL
+ new_att_node % atthandle % attValueReal = attValue
+
+ if (present(fieldname)) then
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_att_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ else
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ handle % attlist_tail % next => new_att_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ end if
+
+ end subroutine MPAS_io_get_att_real0d
+
+
+ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), dimension(:), pointer :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ integer :: xtype, len, attlen
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: att_cursor, new_att_node
+
+! write(0,*) 'Called MPAS_io_get_att_real1d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+
+ ! Check whether we have this attribute cached
+ att_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_REALA) then
+!write(0,*) 'Using cached attribute'
+ allocate(attValue(size(att_cursor % atthandle % attValueRealA)))
+ attValue = att_cursor % atthandle % attValueRealA
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ else
+
+ ! Check whether we have this attribute cached
+ att_cursor => handle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_REALA) then
+!write(0,*) 'Using cached attribute'
+ allocate(attValue(size(att_cursor % atthandle % attValueRealA)))
+ attValue = att_cursor % atthandle % attValueRealA
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ varid = PIO_global
+ end if
+
+ ! Query attribute value
+ pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ if (xtype /= PIO_double) then
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ return
+ end if
+
+ pio_ierr = PIO_inq_attlen(handle % pio_file, varid, attName, attlen)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ allocate(attValue(attlen))
+ pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Keep attribute for future reference
+ allocate(new_att_node)
+ nullify(new_att_node % next)
+ allocate(new_att_node % atthandle)
+ new_att_node % atthandle % attName = attName
+ new_att_node % atthandle % attType = ATT_REALA
+ allocate(new_att_node % atthandle % attValueRealA(attlen))
+ new_att_node % atthandle % attValueRealA = attValue
+
+ if (present(fieldname)) then
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_att_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ else
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ handle % attlist_tail % next => new_att_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ end if
+
+ end subroutine MPAS_io_get_att_real1d
+
+
+ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ character (len=*), intent(out) :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ integer :: xtype, len
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: att_cursor, new_att_node
+
+! write(0,*) 'Called MPAS_io_get_att_text()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ return
+ end if
+
+ ! Check whether we have this attribute cached
+ att_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_TEXT) then
+!write(0,*) 'Using cached attribute'
+ attValue = att_cursor % atthandle % attValueText
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ else
+
+ ! Check whether we have this attribute cached
+ att_cursor => handle % attlist_head
+ do while (associated(att_cursor))
+ if (trim(att_cursor % atthandle % attName) == trim(attName)) then
+ if (att_cursor % atthandle % attType == ATT_TEXT) then
+!write(0,*) 'Using cached attribute'
+ attValue = att_cursor % atthandle % attValueText
+ else
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ end if
+ return
+ end if
+ att_cursor => att_cursor % next
+ end do
+
+ varid = PIO_global
+ end if
+
+ ! Query attribute value
+ pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+ if (xtype /= PIO_char) then
+ if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE
+ return
+ end if
+
+ pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Keep attribute for future reference
+ allocate(new_att_node)
+ nullify(new_att_node % next)
+ allocate(new_att_node % atthandle)
+ new_att_node % atthandle % attName = attName
+ new_att_node % atthandle % attType = ATT_TEXT
+ new_att_node % atthandle % attValueText = attValue
+
+ if (present(fieldname)) then
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_att_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ else
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_att_node
+!write(0,*) 'Assigning att head for '//trim(attName)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_att_node
+!write(0,*) 'Assigning att tail for '//trim(attName)
+ else
+ handle % attlist_tail % next => new_att_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attName)
+ end if
+ end if
+
+ end subroutine MPAS_io_get_att_text
+
+
+ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ integer, intent(in) :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: attlist_cursor, new_attlist_node
+
+! write(0,*) 'Called MPAS_io_put_att_int0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+ if (handle % data_mode) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_DATA_MODE
+ return
+ end if
+ if (handle % iomode /= MPAS_IO_WRITE) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NOWRITE
+ return
+ end if
+
+
+ allocate(new_attlist_node)
+ nullify(new_attlist_node % next)
+ allocate(new_attlist_node % attHandle)
+ new_attlist_node % attHandle % attName = attName
+ new_attlist_node % attHandle % attType = ATT_INT
+ new_attlist_node % attHandle % attValueInt = attValue
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+
+ ! Check whether attribute was already defined
+ attlist_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_INT .or. &
+ attlist_cursor % atthandle % attValueInt /= attValue) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ return
+ end if
+
+ ! Add attribute to field attribute list
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_attlist_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+
+ else
+
+ ! Check whether attribute was already defined
+ attlist_cursor => handle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_INT .or. &
+ attlist_cursor % atthandle % attValueInt /= attValue) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = PIO_global
+
+ ! Add attribute to global attribute list
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ handle % attlist_tail % next => new_attlist_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+ end if
+
+ pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Maybe we should add attribute to list only after a successfull call to PIO?
+
+ end subroutine MPAS_io_put_att_int0d
+
+
+ subroutine MPAS_io_put_att_int1d(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ integer, dimension(:), intent(in) :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: attlist_cursor, new_attlist_node
+
+! write(0,*) 'Called MPAS_io_put_att_int1d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+ if (handle % data_mode) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_DATA_MODE
+ return
+ end if
+ if (handle % iomode /= MPAS_IO_WRITE) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NOWRITE
+ return
+ end if
+
+
+ allocate(new_attlist_node)
+ nullify(new_attlist_node % next)
+ allocate(new_attlist_node % attHandle)
+ new_attlist_node % attHandle % attName = attName
+ new_attlist_node % attHandle % attType = ATT_INTA
+ allocate(new_attlist_node % attHandle % attValueIntA(size(attValue)))
+ new_attlist_node % attHandle % attValueIntA = attValue
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+
+ ! Check whether attribute was already defined
+ attlist_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_INTA .or. &
+ size(attlist_cursor % atthandle % attValueIntA) /= size(attValue)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+! else if (attlist_cursor % atthandle % attValueIntA(:) /= attValue(:)) then ! array sizes should match based on previous if-test
+! if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+! deallocate(new_attlist_node % attHandle)
+! deallocate(new_attlist_node)
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ return
+ end if
+
+ ! Add attribute to field attribute list
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_attlist_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+
+ else
+
+ ! Check whether attribute was already defined
+ attlist_cursor => handle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_INTA .or. &
+ size(attlist_cursor % atthandle % attValueIntA) /= size(attValue)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+! else if (attlist_cursor % atthandle % attValueIntA /= attValue) then
+! else if (attlist_cursor % atthandle % attValueIntA /= attValue) then
+! else if (attlist_cursor % atthandle % attValueIntA /= attValue) then
+! else if (attlist_cursor % atthandle % attValueIntA /= attValue) then
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = PIO_global
+
+ ! Add attribute to global attribute list
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ handle % attlist_tail % next => new_attlist_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+ end if
+
+ pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Maybe we should add attribute to list only after a successfull call to PIO?
+
+ end subroutine MPAS_io_put_att_int1d
+
+
+ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), intent(in) :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: attlist_cursor, new_attlist_node
+
+! write(0,*) 'Called MPAS_io_put_att_real0d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+ if (handle % data_mode) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_DATA_MODE
+ return
+ end if
+ if (handle % iomode /= MPAS_IO_WRITE) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NOWRITE
+ return
+ end if
+
+
+ allocate(new_attlist_node)
+ nullify(new_attlist_node % next)
+ allocate(new_attlist_node % attHandle)
+ new_attlist_node % attHandle % attName = attName
+ new_attlist_node % attHandle % attType = ATT_REAL
+ new_attlist_node % attHandle % attValueReal = attValue
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+
+ ! Check whether attribute was already defined
+ attlist_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_REAL .or. &
+ attlist_cursor % atthandle % attValueReal /= attValue) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ return
+ end if
+
+ ! Add attribute to field attribute list
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_attlist_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+
+ else
+
+ ! Check whether attribute was already defined
+ attlist_cursor => handle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_REAL .or. &
+ attlist_cursor % atthandle % attValueReal /= attValue) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = PIO_global
+
+ ! Add attribute to global attribute list
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ handle % attlist_tail % next => new_attlist_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+ end if
+
+ pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Maybe we should add attribute to list only after a successfull call to PIO?
+
+ end subroutine MPAS_io_put_att_real0d
+
+
+ subroutine MPAS_io_put_att_real1d(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), dimension(:), intent(in) :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: attlist_cursor, new_attlist_node
+
+! write(0,*) 'Called MPAS_io_put_att_real1d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+ if (handle % data_mode) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_DATA_MODE
+ return
+ end if
+ if (handle % iomode /= MPAS_IO_WRITE) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NOWRITE
+ return
+ end if
+
+
+ allocate(new_attlist_node)
+ nullify(new_attlist_node % next)
+ allocate(new_attlist_node % attHandle)
+ new_attlist_node % attHandle % attName = attName
+ new_attlist_node % attHandle % attType = ATT_REALA
+ allocate(new_attlist_node % attHandle % attValueRealA(size(attValue)))
+ new_attlist_node % attHandle % attValueRealA = attValue
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+
+ ! Check whether attribute was already defined
+ attlist_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_REALA .or. &
+ size(attlist_cursor % atthandle % attValueRealA) /= size(attValue)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+! else if (attlist_cursor % atthandle % attValueIntA(:) /= attValue(:)) then ! array sizes should match based on previous if-test
+! if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+! deallocate(new_attlist_node % attHandle)
+! deallocate(new_attlist_node)
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ return
+ end if
+
+ ! Add attribute to field attribute list
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_attlist_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+
+ else
+
+ ! Check whether attribute was already defined
+ attlist_cursor => handle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_REALA .or. &
+ size(attlist_cursor % atthandle % attValueRealA) /= size(attValue)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+! else if (attlist_cursor % atthandle % attValueIntA /= attValue) then
+! else if (attlist_cursor % atthandle % attValueIntA /= attValue) then
+! else if (attlist_cursor % atthandle % attValueIntA /= attValue) then
+! else if (attlist_cursor % atthandle % attValueIntA /= attValue) then
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = PIO_global
+
+ ! Add attribute to global attribute list
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ handle % attlist_tail % next => new_attlist_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+ end if
+
+ pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValue)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Maybe we should add attribute to list only after a successfull call to PIO?
+
+ end subroutine MPAS_io_put_att_real1d
+
+
+ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: attName
+ character (len=*), intent(in) :: attValue
+ character (len=*), intent(in), optional :: fieldname
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ integer :: varid
+ type (fieldlist_type), pointer :: field_cursor
+ type (attlist_type), pointer :: attlist_cursor, new_attlist_node
+
+! write(0,*) 'Called MPAS_io_put_att_text()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+ if (handle % data_mode) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_DATA_MODE
+ return
+ end if
+ if (handle % iomode /= MPAS_IO_WRITE) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_NOWRITE
+ return
+ end if
+
+
+ allocate(new_attlist_node)
+ nullify(new_attlist_node % next)
+ allocate(new_attlist_node % attHandle)
+ new_attlist_node % attHandle % attName = attName
+ new_attlist_node % attHandle % attType = ATT_TEXT
+ new_attlist_node % attHandle % attValueText = attValue
+
+
+ !
+ ! For variable attributes, find the structure for fieldname
+ !
+ if (present(fieldname)) then
+ field_cursor => handle % fieldlist_head
+ do while (associated(field_cursor))
+ if (trim(fieldname) == trim(field_cursor % fieldhandle % fieldname)) then
+
+ ! Check whether attribute was already defined
+ attlist_cursor => field_cursor % fieldhandle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_TEXT .or. &
+ trim(attlist_cursor % atthandle % attValueText) /= trim(attValue)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = field_cursor % fieldhandle % fieldid
+ exit
+ end if
+ field_cursor => field_cursor % next
+ end do
+ if (.not. associated(field_cursor)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNDEFINED_VAR
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ return
+ end if
+
+ ! Add attribute to field attribute list
+ if (.not. associated(field_cursor % fieldhandle % attlist_head)) then
+ field_cursor % fieldhandle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(field_cursor % fieldhandle % attlist_tail)) then
+ field_cursor % fieldhandle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ field_cursor % fieldhandle % attlist_tail % next => new_attlist_node
+ field_cursor % fieldhandle % attlist_tail => field_cursor % fieldhandle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+
+ else
+
+ ! Check whether attribute was already defined
+ attlist_cursor => handle % attlist_head
+ do while (associated(attlist_cursor))
+ if (trim(attName) == trim(attlist_cursor % atthandle % attName)) then
+!write(0,*) 'Attribute already defined'
+ if (attlist_cursor % atthandle % attType /= ATT_TEXT .or. &
+ trim(attlist_cursor % atthandle % attValueText) /= trim(attValue)) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_ATT
+ deallocate(new_attlist_node % attHandle)
+ deallocate(new_attlist_node)
+ end if
+ return
+ end if
+ attlist_cursor => attlist_cursor % next
+ end do
+
+ varid = PIO_global
+
+ ! Add attribute to global attribute list
+ if (.not. associated(handle % attlist_head)) then
+ handle % attlist_head => new_attlist_node
+!write(0,*) 'Assigning att head for '//trim(attname)
+ end if
+ if (.not. associated(handle % attlist_tail)) then
+ handle % attlist_tail => new_attlist_node
+!write(0,*) 'Assigning att tail for '//trim(attname)
+ else
+ handle % attlist_tail % next => new_attlist_node
+ handle % attlist_tail => handle % attlist_tail % next
+!write(0,*) 'Extending att tail for '//trim(attname)
+ end if
+ end if
+
+ pio_ierr = PIO_put_att(handle % pio_file, varid, attName, trim(attValue))
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ ! Maybe we should add attribute to list only after a successfull call to PIO?
+
+ end subroutine MPAS_io_put_att_text
+
+
+ subroutine MPAS_io_set_frame(handle, frame, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ integer, intent(in) :: frame
+ integer, intent(out), optional :: ierr
+
+! write(0,*) 'Called MPAS_io_set_frame()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ handle % frame_number = frame
+
+ end subroutine MPAS_io_set_frame
+
+
+ subroutine MPAS_io_advance_frame(handle, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ integer, intent(out), optional :: ierr
+
+! write(0,*) 'Called MPAS_io_advance_frame()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ handle % frame_number = handle % frame_number + 1
+
+ end subroutine MPAS_io_advance_frame
+
+
+ subroutine MPAS_io_sync(handle, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ integer, intent(out), optional :: ierr
+
+! write(0,*) 'Called MPAS_io_sync()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+ call PIO_syncfile(handle % pio_file)
+
+ end subroutine MPAS_io_sync
+
+
+ subroutine MPAS_io_close(handle, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ integer, intent(out), optional :: ierr
+
+ type (dimlist_type), pointer :: dimlist_ptr, dimlist_del
+ type (fieldlist_type), pointer :: fieldlist_ptr, fieldlist_del
+ type (attlist_type), pointer :: attlist_ptr, attlist_del
+
+! write(0,*) 'Called MPAS_io_close()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ ! Sanity checks
+ if (.not. handle % initialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE
+ return
+ end if
+
+ ! Deallocate memory associated with the file
+ fieldlist_ptr => handle % fieldlist_head
+ do while (associated(fieldlist_ptr))
+ fieldlist_del => fieldlist_ptr
+ fieldlist_ptr => fieldlist_ptr % next
+
+ attlist_ptr => fieldlist_del % fieldhandle % attlist_head
+ do while (associated(attlist_ptr))
+ attlist_del => attlist_ptr
+ attlist_ptr => attlist_ptr % next
+ if (attlist_del % atthandle % attType == ATT_INTA) deallocate(attlist_del % atthandle % attValueIntA)
+ if (attlist_del % atthandle % attType == ATT_REALA) deallocate(attlist_del % atthandle % attValueRealA)
+ deallocate(attlist_del % atthandle)
+ end do
+ nullify(fieldlist_del % fieldhandle % attlist_head)
+ nullify(fieldlist_del % fieldhandle % attlist_tail)
+
+ deallocate(fieldlist_del % fieldhandle % dims)
+
+ deallocate(fieldlist_del % fieldhandle)
+ end do
+ nullify(handle % fieldlist_head)
+ nullify(handle % fieldlist_tail)
+
+ dimlist_ptr => handle % dimlist_head
+ do while (associated(dimlist_ptr))
+ dimlist_del => dimlist_ptr
+ dimlist_ptr => dimlist_ptr % next
+ deallocate(dimlist_del % dimhandle)
+ end do
+ nullify(handle % dimlist_head)
+ nullify(handle % dimlist_tail)
+
+ attlist_ptr => handle % attlist_head
+ do while (associated(attlist_ptr))
+ attlist_del => attlist_ptr
+ attlist_ptr => attlist_ptr % next
+ if (attlist_del % atthandle % attType == ATT_INTA) deallocate(attlist_del % atthandle % attValueIntA)
+ if (attlist_del % atthandle % attType == ATT_REALA) deallocate(attlist_del % atthandle % attValueRealA)
+ deallocate(attlist_del % atthandle)
+ end do
+ nullify(handle % attlist_head)
+ nullify(handle % attlist_tail)
+
+ handle % initialized = .false.
+
+!write(0,*) 'MGD PIO_closefile'
+ call PIO_closefile(handle % pio_file)
+
+ end subroutine MPAS_io_close
+
+
+ subroutine MPAS_io_finalize(ierr)
+
+ implicit none
+
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (decomplist_type), pointer :: decomp_cursor, decomp_del
+
+! write(0,*) 'Called MPAS_io_finalize()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ decomp_cursor => decomp_list
+ do while (associated(decomp_cursor))
+ decomp_del => decomp_cursor
+ decomp_cursor => decomp_cursor % next
+!write(0,*) 'Deallocating a decomposition...'
+!if (.not. associated(decomp_del % decomphandle)) write(0,*) 'OOPS... do not have decomphandle'
+ deallocate(decomp_del % decomphandle % dims)
+ deallocate(decomp_del % decomphandle % indices)
+ call PIO_freedecomp(pio_iosystem, decomp_del % decomphandle % pio_iodesc)
+ deallocate(decomp_del % decomphandle)
+ deallocate(decomp_del)
+ end do
+
+!write(0,*) 'MGD PIO_finalize'
+ call PIO_finalize(pio_iosystem, pio_ierr)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+
+ end subroutine MPAS_io_finalize
+
+
+ subroutine MPAS_io_err_mesg(ierr, fatal)
+
+ implicit none
+
+ integer, intent(in) :: ierr
+ logical, intent(in) :: fatal
+
+ select case (ierr)
+ case (MPAS_IO_NOERR)
+ ! ... do nothing ...
+ case (MPAS_IO_ERR_INVALID_MODE)
+ write(0,*) 'MPAS IO Error: Invalid file access mode'
+ case (MPAS_IO_ERR_INVALID_FORMAT)
+ write(0,*) 'MPAS IO Error: Invalid I/O format'
+ case (MPAS_IO_ERR_LONG_FILENAME)
+ write(0,*) 'MPAS IO Error: Filename too long'
+ case (MPAS_IO_ERR_UNINIT_HANDLE)
+ write(0,*) 'MPAS IO Error: Uninitialized I/O handle'
+ case (MPAS_IO_ERR_PIO)
+ write(0,*) 'MPAS IO Error: Bad return value from PIO'
+ case (MPAS_IO_ERR_DATA_MODE)
+ write(0,*) 'MPAS IO Error: Cannot define in data mode'
+ case (MPAS_IO_ERR_NOWRITE)
+ write(0,*) 'MPAS IO Error: File not opened for writing'
+ case (MPAS_IO_ERR_REDEF_DIM)
+ write(0,*) 'MPAS IO Error: Inconsistent redefinition of dimension'
+ case (MPAS_IO_ERR_REDEF_VAR)
+ write(0,*) 'MPAS IO Error: Inconsistent redefinition of field'
+ case (MPAS_IO_ERR_UNDEFINED_DIM)
+ write(0,*) 'MPAS IO Error: Field uses undefined dimension'
+ case (MPAS_IO_ERR_UNDEFINED_VAR)
+ write(0,*) 'MPAS IO Error: Undefined field'
+ case (MPAS_IO_ERR_REDEF_ATT)
+ write(0,*) 'MPAS IO Error: Inconsistent redefinition of attribute'
+ case (MPAS_IO_ERR_WRONG_ATT_TYPE)
+ write(0,*) 'MPAS IO Error: Wrong type for requested attribute'
+ case (MPAS_IO_ERR_NO_DECOMP)
+ write(0,*) 'MPAS IO Error: Decomposition indices not set for field'
+ case (MPAS_IO_ERR_TWO_UNLIMITED_DIMS)
+ write(0,*) 'MPAS IO Error: Defining more than one unlimited dimension'
+ case (MPAS_IO_ERR_WRONG_MODE)
+ write(0,*) 'MPAS IO Error: Operation not permitted in this file mode'
+ case (MPAS_IO_ERR_NO_UNLIMITED_DIM)
+ write(0,*) 'MPAS IO Error: No unlimited dimension found in dataset'
+ case (MPAS_IO_ERR_UNIMPLEMENTED)
+ write(0,*) 'MPAS IO Error: Unimplemented functionality'
+ case default
+ write(0,*) 'MPAS IO Error: Unrecognized error code...'
+ end select
+
+ if (fatal .and. (ierr /= MPAS_IO_NOERR)) call mpas_dmpar_abort(local_dminfo)
+
+ end subroutine MPAS_io_err_mesg
+
+end module mpas_io
Modified: trunk/mpas/src/framework/mpas_io_input.F
===================================================================
--- trunk/mpas/src/framework/mpas_io_input.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/framework/mpas_io_input.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -6,6 +6,7 @@
use mpas_sort
use mpas_configure
use mpas_timekeeping
+ use mpas_io_streams
#ifdef HAVE_ZOLTAN
@@ -21,31 +22,11 @@
integer :: time
-#include "io_input_obj_decls.inc"
+ type (MPAS_Stream_type) :: io_stream
+
end type io_input_object
- interface mpas_io_input_field
- module procedure mpas_io_input_field0d_real
- module procedure mpas_io_input_field1d_real
- module procedure mpas_io_input_field2d_real
- module procedure mpas_io_input_field3d_real
- module procedure mpas_io_input_field1d_integer
- module procedure mpas_io_input_field2d_integer
- module procedure mpas_io_input_field0d_char
- module procedure mpas_io_input_field1d_char
- end interface mpas_io_input_field
-
- interface mpas_io_input_field_time
- module procedure mpas_io_input_field0d_real_time
- module procedure mpas_io_input_field1d_real_time
- module procedure mpas_io_input_field2d_real_time
- module procedure mpas_io_input_field3d_real_time
- module procedure mpas_io_input_field1d_integer_time
- module procedure mpas_io_input_field0d_char_time
- module procedure mpas_io_input_field1d_char_time
- end interface mpas_io_input_field_time
-
type (exchange_list), pointer :: sendCellList, recvCellList
type (exchange_list), pointer :: sendEdgeList, recvEdgeList
type (exchange_list), pointer :: sendVertexList, recvVertexList
@@ -72,6 +53,10 @@
character (len=16) :: c_on_a_sphere
real (kind=RKIND) :: r_sphere_radius
+
+ integer :: ierr
+ integer, dimension(:), pointer :: readIndices
+ type (MPAS_IO_Handle_type) :: inputHandle
type (field1dInteger) :: indexToCellIDField
type (field1dInteger) :: indexToEdgeIDField
@@ -93,12 +78,15 @@
type (field1DChar) :: xtime
- integer, dimension(:), pointer :: indexToCellID_0Halo
- integer, dimension(:), pointer :: nEdgesOnCell_0Halo
+ integer, dimension(:), pointer :: indexToCellID_0Halo
+ integer, dimension(:), pointer :: nEdgesOnCell_0Halo
integer, dimension(:,:), pointer :: cellsOnCell_0Halo
-
+
+ integer, dimension(:), pointer :: nEdgesOnCell_2Halo
+
integer, dimension(:,:), pointer :: edgesOnCell_2Halo
integer, dimension(:,:), pointer :: verticesOnCell_2Halo
+
integer, dimension(:,:), pointer :: cellsOnEdge_2Halo
integer, dimension(:,:), pointer :: cellsOnVertex_2Halo
@@ -115,6 +103,7 @@
#endif
integer, dimension(:), pointer :: local_cell_list, local_edge_list, local_vertex_list
+ 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
@@ -130,6 +119,22 @@
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, 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(:), pointer :: tempIDs
+ integer :: ntempIDs, offset
+
+ integer :: nHalo, nOwnCells, nOwnEdges, nOwnVertices, cellCount, edgeCount, vertexCount, iEdge, iVertex
+ type (hashtable) :: edgeHash, vertexHash
+
+
if (config_do_restart) then
! this get followed by set is to ensure that the time is in standard format
@@ -144,7 +149,19 @@
input_obj % filename = trim(config_input_name)
input_obj % stream = STREAM_INPUT
end if
- call mpas_io_input_init(input_obj, domain % dminfo)
+ inputHandle = MPAS_io_open(trim(input_obj % filename), MPAS_IO_READ, MPAS_IO_PNETCDF, ierr)
+ if (ierr /= MPAS_IO_NOERR) then
+ write(0,*) ' '
+ if (input_obj % stream == STREAM_RESTART) then
+ write(0,*) 'Error opening restart file ''', trim(input_obj % filename), ''''
+ else if (input_obj % stream == STREAM_INPUT) then
+ write(0,*) 'Error opening input file ''', trim(input_obj % filename), ''''
+ else if (input_obj % stream == STREAM_SFC) then
+ write(0,*) 'Error opening sfc file ''', trim(input_obj % filename), ''''
+ end if
+ write(0,*) ' '
+ call mpas_dmpar_abort(domain % dminfo)
+ end if
!
@@ -157,10 +174,10 @@
! from the input file
!
call mpas_dmpar_get_index_range(domain % dminfo, 1, nCells, readCellStart, readCellEnd)
- nReadCells = readCellEnd - readCellStart + 1
+ nReadCells = readCellEnd - readCellStart + 1
call mpas_dmpar_get_index_range(domain % dminfo, 1, nEdges, readEdgeStart, readEdgeEnd)
- nReadEdges = readEdgeEnd - readEdgeStart + 1
+ nReadEdges = readEdgeEnd - readEdgeStart + 1
call mpas_dmpar_get_index_range(domain % dminfo, 1, nVertices, readVertexStart, readVertexEnd)
nReadVertices = readVertexEnd - readVertexStart + 1
@@ -181,7 +198,13 @@
indexToCellIDField % ioinfo % start(1) = readCellStart
indexToCellIDField % ioinfo % count(1) = nReadCells
allocate(indexToCellIDField % array(nReadCells))
- call mpas_io_input_field(input_obj, indexToCellIDField)
+ allocate(readIndices(nReadCells))
+ do i=1,nReadCells
+ readIndices(i) = i + readCellStart - 1
+ end do
+ call MPAS_io_inq_var(inputHandle, 'indexToCellID', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'indexToCellID', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'indexToCellID', indexToCellIDField % array, ierr)
#ifdef HAVE_ZOLTAN
#ifdef _MPI
@@ -191,7 +214,9 @@
xCellField % ioinfo % start(1) = readCellStart
xCellField % ioinfo % count(1) = nReadCells
allocate(xCellField % array(nReadCells))
- call mpas_io_input_field(input_obj, xCellField)
+ call MPAS_io_inq_var(inputHandle, 'xCell', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'xCell', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'xCell', xCellField % array, ierr)
! Cell y-coordinates (in 3d Cartesian space)
allocate(yCellField % ioinfo)
@@ -199,7 +224,9 @@
yCellField % ioinfo % start(1) = readCellStart
yCellField % ioinfo % count(1) = nReadCells
allocate(yCellField % array(nReadCells))
- call mpas_io_input_field(input_obj, yCellField)
+ 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)
! Cell z-coordinates (in 3d Cartesian space)
allocate(zCellField % ioinfo)
@@ -207,9 +234,12 @@
zCellField % ioinfo % start(1) = readCellStart
zCellField % ioinfo % count(1) = nReadCells
allocate(zCellField % array(nReadCells))
- call mpas_io_input_field(input_obj, zCellField)
+ call MPAS_io_inq_var(inputHandle, 'zCell', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'zCell', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'zCell', zCellField % array, ierr)
#endif
#endif
+ deallocate(readIndices)
! Global edge indices
@@ -218,7 +248,14 @@
indexToEdgeIDField % ioinfo % start(1) = readEdgeStart
indexToEdgeIDField % ioinfo % count(1) = nReadEdges
allocate(indexToEdgeIDField % array(nReadEdges))
- call mpas_io_input_field(input_obj, indexToEdgeIDField)
+ allocate(indexToEdgeIDField % array(nReadEdges))
+ allocate(readIndices(nReadEdges))
+ do i=1,nReadEdges
+ readIndices(i) = i + readEdgeStart - 1
+ end do
+ call MPAS_io_inq_var(inputHandle, 'indexToEdgeID', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'indexToEdgeID', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'indexToEdgeID', indexToEdgeIDField % array, ierr)
#ifdef HAVE_ZOLTAN
#ifdef _MPI
@@ -228,7 +265,9 @@
xEdgeField % ioinfo % start(1) = readEdgeStart
xEdgeField % ioinfo % count(1) = nReadEdges
allocate(xEdgeField % array(nReadEdges))
- call mpas_io_input_field(input_obj, xEdgeField)
+ call MPAS_io_inq_var(inputHandle, 'xEdge', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'xEdge', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'xEdge', xEdgeField % array, ierr)
! Edge y-coordinates (in 3d Cartesian space)
allocate(yEdgeField % ioinfo)
@@ -236,7 +275,9 @@
yEdgeField % ioinfo % start(1) = readEdgeStart
yEdgeField % ioinfo % count(1) = nReadEdges
allocate(yEdgeField % array(nReadEdges))
- call mpas_io_input_field(input_obj, yEdgeField)
+ call MPAS_io_inq_var(inputHandle, 'yEdge', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'yEdge', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'yEdge', yEdgeField % array, ierr)
! Edge z-coordinates (in 3d Cartesian space)
allocate(zEdgeField % ioinfo)
@@ -244,17 +285,27 @@
zEdgeField % ioinfo % start(1) = readEdgeStart
zEdgeField % ioinfo % count(1) = nReadEdges
allocate(zEdgeField % array(nReadEdges))
- call mpas_io_input_field(input_obj, zEdgeField)
+ call MPAS_io_inq_var(inputHandle, 'zEdge', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'zEdge', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'zEdge', zEdgeField % array, ierr)
#endif
#endif
+ deallocate(readIndices)
+
! Global vertex indices
allocate(indexToVertexIDField % ioinfo)
indexToVertexIDField % ioinfo % fieldName = 'indexToVertexID'
indexToVertexIDField % ioinfo % start(1) = readVertexStart
indexToVertexIDField % ioinfo % count(1) = nReadVertices
allocate(indexToVertexIDField % array(nReadVertices))
- call mpas_io_input_field(input_obj, indexToVertexIDField)
+ allocate(readIndices(nReadVertices))
+ do i=1,nReadVertices
+ readIndices(i) = i + readVertexStart - 1
+ end do
+ call MPAS_io_inq_var(inputHandle, 'indexToVertexID', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'indexToVertexID', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'indexToVertexID', indexToVertexIDField % array, ierr)
#ifdef HAVE_ZOLTAN
#ifdef _MPI
@@ -264,7 +315,9 @@
xVertexField % ioinfo % start(1) = readVertexStart
xVertexField % ioinfo % count(1) = nReadVertices
allocate(xVertexField % array(nReadVertices))
- call mpas_io_input_field(input_obj, xVertexField)
+ call MPAS_io_inq_var(inputHandle, 'xVertex', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'xVertex', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'xVertex', xVertexField % array, ierr)
! Vertex y-coordinates (in 3d Cartesian space)
allocate(yVertexField % ioinfo)
@@ -272,7 +325,9 @@
yVertexField % ioinfo % start(1) = readVertexStart
yVertexField % ioinfo % count(1) = nReadVertices
allocate(yVertexField % array(nReadVertices))
- call mpas_io_input_field(input_obj, yVertexField)
+ call MPAS_io_inq_var(inputHandle, 'yVertex', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'yVertex', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'yVertex', yVertexField % array, ierr)
! Vertex z-coordinates (in 3d Cartesian space)
allocate(zVertexField % ioinfo)
@@ -280,9 +335,12 @@
zVertexField % ioinfo % start(1) = readVertexStart
zVertexField % ioinfo % count(1) = nReadVertices
allocate(zVertexField % array(nReadVertices))
- call mpas_io_input_field(input_obj, zVertexField)
+ call MPAS_io_inq_var(inputHandle, 'zVertex', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'zVertex', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'zVertex', zVertexField % array, ierr)
#endif
#endif
+ deallocate(readIndices)
! Number of cell/edges/vertices adjacent to each cell
allocate(nEdgesOnCellField % ioinfo)
@@ -290,7 +348,13 @@
nEdgesOnCellField % ioinfo % start(1) = readCellStart
nEdgesOnCellField % ioinfo % count(1) = nReadCells
allocate(nEdgesOnCellField % array(nReadCells))
- call mpas_io_input_field(input_obj, nEdgesOnCellField)
+ allocate(readIndices(nReadCells))
+ do i=1,nReadCells
+ readIndices(i) = i + readCellStart - 1
+ end do
+ call MPAS_io_inq_var(inputHandle, 'nEdgesOnCell', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'nEdgesOnCell', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'nEdgesOnCell', nEdgesOnCellField % array, ierr)
! Global indices of cells adjacent to each cell
allocate(cellsOnCellField % ioinfo)
@@ -300,7 +364,9 @@
cellsOnCellField % ioinfo % count(1) = maxEdges
cellsOnCellField % ioinfo % count(2) = nReadCells
allocate(cellsOnCellField % array(maxEdges,nReadCells))
- call mpas_io_input_field(input_obj, cellsOnCellField)
+ call MPAS_io_inq_var(inputHandle, 'cellsOnCell', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'cellsOnCell', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'cellsOnCell', cellsOnCellField % array, ierr)
! Global indices of edges adjacent to each cell
allocate(edgesOnCellField % ioinfo)
@@ -310,7 +376,9 @@
edgesOnCellField % ioinfo % count(1) = maxEdges
edgesOnCellField % ioinfo % count(2) = nReadCells
allocate(edgesOnCellField % array(maxEdges,nReadCells))
- call mpas_io_input_field(input_obj, edgesOnCellField)
+ call MPAS_io_inq_var(inputHandle, 'edgesOnCell', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'edgesOnCell', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'edgesOnCell', edgesOnCellField % array, ierr)
! Global indices of vertices adjacent to each cell
allocate(verticesOnCellField % ioinfo)
@@ -320,7 +388,10 @@
verticesOnCellField % ioinfo % count(1) = maxEdges
verticesOnCellField % ioinfo % count(2) = nReadCells
allocate(verticesOnCellField % array(maxEdges,nReadCells))
- call mpas_io_input_field(input_obj, verticesOnCellField)
+ call MPAS_io_inq_var(inputHandle, 'verticesOnCell', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'verticesOnCell', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'verticesOnCell', verticesOnCellField % array, ierr)
+ deallocate(readIndices)
! Global indices of cells adjacent to each edge
! used for determining which edges are owned by a block, where
@@ -332,7 +403,14 @@
cellsOnEdgeField % ioinfo % count(1) = 2
cellsOnEdgeField % ioinfo % count(2) = nReadEdges
allocate(cellsOnEdgeField % array(2,nReadEdges))
- call mpas_io_input_field(input_obj, cellsOnEdgeField)
+ allocate(readIndices(nReadEdges))
+ do i=1,nReadEdges
+ readIndices(i) = i + readEdgeStart - 1
+ end do
+ call MPAS_io_inq_var(inputHandle, 'cellsOnEdge', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'cellsOnEdge', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'cellsOnEdge', cellsOnEdgeField % array, ierr)
+ deallocate(readIndices)
! Global indices of cells adjacent to each vertex
! used for determining which vertices are owned by a block, where
@@ -344,7 +422,14 @@
cellsOnVertexField % ioinfo % count(1) = vertexDegree
cellsOnVertexField % ioinfo % count(2) = nReadVertices
allocate(cellsOnVertexField % array(vertexDegree,nReadVertices))
- call mpas_io_input_field(input_obj, cellsOnVertexField)
+ allocate(readIndices(nReadVertices))
+ do i=1,nReadVertices
+ readIndices(i) = i + readVertexStart - 1
+ end do
+ call MPAS_io_inq_var(inputHandle, 'cellsOnVertex', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'cellsOnVertex', readIndices, ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'cellsOnVertex', cellsOnVertexField % array, ierr)
+ deallocate(readIndices)
!
@@ -373,7 +458,7 @@
! Determine which cells are owned by this process
- call mpas_block_decomp_cells_for_proc(domain % dminfo, partial_global_graph_info, local_cell_list)
+ call mpas_block_decomp_cells_for_proc(domain % dminfo, partial_global_graph_info, local_cell_list, block_id, block_start, block_count)
deallocate(partial_global_graph_info % vertexID)
deallocate(partial_global_graph_info % nAdjacent)
@@ -489,6 +574,8 @@
block_graph_2Halo % nVertices = block_graph_0Halo % nVertices
block_graph_2Halo % ghostStart = block_graph_2Halo % nVertices + 1
+ nOwnCells = block_graph_2Halo % nVertices
+
#ifdef HAVE_ZOLTAN
#ifdef _MPI
!! For now, only use Zoltan with MPI
@@ -524,6 +611,7 @@
! on each cell and which vertices are on each cell from the processes that read these
! fields for each cell to the processes that own the cells
!
+ allocate(nEdgesOnCell_2Halo(block_graph_2Halo % nVerticesTotal))
allocate(edgesOnCell_2Halo(maxEdges, block_graph_2Halo % nVerticesTotal))
allocate(verticesOnCell_2Halo(maxEdges, block_graph_2Halo % nVerticesTotal))
@@ -532,6 +620,10 @@
indexToCellIDField % array, block_graph_2Halo % vertexID, &
sendCellList, recvCellList)
+ call mpas_dmpar_alltoall_field(domain % dminfo, nEdgesOnCellField % array, nEdgesOnCell_2Halo, &
+ size(indexToCellIDField % array), size(local_cell_list), &
+ sendCellList, recvCellList)
+
call mpas_dmpar_alltoall_field(domain % dminfo, edgesOnCellField % array, edgesOnCell_2Halo, &
maxEdges, nReadCells, block_graph_2Halo % nVerticesTotal, &
sendCellList, recvCellList)
@@ -576,15 +668,90 @@
sendVertexList, recvVertexList)
- call mpas_block_decomp_partitioned_edge_list(block_graph_2Halo % nVertices, &
- block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), &
+ call mpas_block_decomp_partitioned_edge_list(nOwnCells, &
+ block_graph_2Halo % vertexID(1:nOwnCells), &
2, nlocal_edges, cellsOnEdge_2Halo, local_edge_list, ghostEdgeStart)
- call mpas_block_decomp_partitioned_edge_list(block_graph_2Halo % nVertices, &
- block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), &
+
+ call mpas_block_decomp_partitioned_edge_list(nOwnCells, &
+ block_graph_2Halo % vertexID(1:nOwnCells), &
vertexDegree, nlocal_vertices, cellsOnVertex_2Halo, local_vertex_list, ghostVertexStart)
+ !------- set owned and halo cell indices -------!
+
+ nCellsCumulative(1) = nOwnCells
+ nCellsCumulative(2) = block_graph_1Halo % nVerticesTotal
+ nCellsCumulative(3) = block_graph_2Halo % nVerticesTotal
- ! At this point, local_edge_list(1;ghostEdgeStart-1) contains all of the owned edges for this block
+ !------- determin the perimeter and owned edges of own cells and halos -------!
+
+ nOwnEdges = ghostEdgeStart-1
+ nOwnVertices = ghostVertexStart-1
+
+ ! skip the own edges found at the beginning of local_edge_list
+ call mpas_hash_init(edgeHash)
+ do i=1,nOwnEdges
+ call mpas_hash_insert(edgeHash, local_edge_list(i))
+ end do
+
+ ! skip the own vertices found at the beginning of local_vertex_list
+ call mpas_hash_init(vertexHash)
+ do i=1,nOwnVertices
+ call mpas_hash_insert(vertexHash, local_vertex_list(i))
+ end do
+
+ cellCount = 1 !tracks the index of the local cell array
+ edgeCount = nOwnEdges !tracks where to insert the next local edge
+ vertexCount = nOwnVertices !tracks where to insert the next local vertex
+
+ nEdgesCumulative(1) = nOwnEdges
+ nVerticesCumulative(1) = nOwnVertices
+
+ !Order the local_edge_list and local_vertex_list accordingly and set the bounds of each perimeter ----
+ do i = 1, nHalos + 1 ! for the own cells and each halo...
+ do j = cellCount, nCellsCumulative(i)
+
+ ! the number of edges on a cell is same to the number of vertices, and therefore
+ ! nEdgesOnCell_2Halo(j) will be the correct upper bound for both both edges and vertices on cell
+ do k = 1, nEdgesOnCell_2Halo(j)
+ iEdge = edgesOnCell_2Halo(k,j)
+ if (.not. mpas_hash_search(edgeHash, iEdge)) then
+ edgeCount = edgeCount + 1
+ local_edge_list(edgeCount) = iEdge
+ call mpas_hash_insert(edgeHash, iEdge)
+ end if
+
+ iVertex = verticesOnCell_2Halo(k,j)
+ if (.not. mpas_hash_search(vertexHash, iVertex)) then
+ vertexCount = vertexCount + 1
+ local_vertex_list(vertexCount) = iVertex
+ call mpas_hash_insert(vertexHash, iVertex)
+ end if
+ end do
+
+ end do
+
+ cellCount = nCellsCumulative(i) + 1
+ nEdgesCumulative(i+1) = edgeCount
+ nVerticesCumulative(i+1) = vertexCount
+ end do
+
+ do i = 1, nHalos
+ nCellsHalo(i) = nCellsCumulative(i+1) - nCellsCumulative(i)
+ end do
+
+ do i = 1, nHalos + 1
+ nEdgesHalo(i) = nEdgesCumulative(i+1) - nEdgesCumulative(i)
+ end do
+
+ do i = 1, nHalos + 1
+ nVerticesHalo(i) = nVerticesCumulative(i+1) - nVerticesCumulative(i)
+ end do
+
+ call mpas_hash_destroy(edgeHash)
+ call mpas_hash_destroy(vertexHash)
+
+
+ ! At this point, local_edge_list(1:nOwnEdges) contains all of the owned edges for this block
! and local_edge_list(ghostEdgeStart:nlocal_edges) contains all of the ghost edges
! At this point, local_vertex_list(1;ghostVertexStart-1) contains all of the owned vertices for this block
@@ -656,13 +823,13 @@
!!!!!!!!!!!!!!!!!!
!! Reorder edges
!!!!!!!!!!!!!!!!!!
- call mpas_zoltan_order_loc_hsfc_edges(ghostEdgeStart-1,local_edge_list,3,xEdge,yEdge,zEdge)
+ call mpas_zoltan_order_loc_hsfc_edges(nOwnEdges,local_edge_list,3,xEdge,yEdge,zEdge)
!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!
!! Reorder vertices
!!!!!!!!!!!!!!!!!!
- call mpas_zoltan_order_loc_hsfc_verts(ghostVertexStart-1,local_vertex_list,3,xVertex,yVertex,zVertex)
+ call mpas_zoltan_order_loc_hsfc_verts(nOwnVertices,local_vertex_list,3,xVertex,yVertex,zVertex)
!!!!!!!!!!!!!!!!!!
deallocate(sendEdgeList % list)
@@ -730,71 +897,69 @@
nEdges = nlocal_edges
nVertices = nlocal_vertices
- call mpas_allocate_block(domain % blocklist, domain, &
+ call mpas_allocate_block(domain % blocklist, domain, domain%dminfo%my_proc_id, &
#include "dim_dummy_args.inc"
)
+!!!!!!!!!!MGD HERE WE NEED TO READ IN indexTo*ID fields !!!!!!!!!!!!!!!!!
+ call MPAS_io_inq_var(inputHandle, 'indexToCellID', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'indexToCellID', local_cell_list(1:nOwnCells), ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'indexToCellID', domain % blocklist % mesh % indexToCellID % array, ierr)
+
+ call MPAS_io_inq_var(inputHandle, 'indexToEdgeID', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'indexToEdgeID', local_edge_list(1:nOwnEdges), ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'indexToEdgeID', domain % blocklist % mesh % indexToEdgeID % array, ierr)
+
+ call MPAS_io_inq_var(inputHandle, 'indexToVertexID', ierr=ierr)
+ call MPAS_io_set_var_indices(inputHandle, 'indexToVertexID', local_vertex_list(1:nOwnVertices), ierr=ierr)
+ call mpas_io_get_var(inputHandle, 'indexToVertexID', domain % blocklist % mesh % indexToVertexID % array, ierr)
+
+ domain % blocklist % mesh % nCellsSolve = nOwnCells
+ domain % blocklist % mesh % nEdgesSolve = nOwnEdges
+ domain % blocklist % mesh % nVerticesSolve = nOwnVertices
+ domain % blocklist % mesh % nVertLevelsSolve = domain % blocklist % mesh % nVertLevels ! No vertical decomp yet...
+
+ call mpas_io_input_init(input_obj, domain % blocklist, domain % dminfo)
+
+
!
! Read attributes
!
- call mpas_io_input_get_att_text(input_obj, 'on_a_sphere', c_on_a_sphere)
- call mpas_io_input_get_att_real(input_obj, 'sphere_radius', r_sphere_radius)
- if (index(c_on_a_sphere, 'YES') /= 0) then
+ call MPAS_readStreamAtt(input_obj % io_stream, 'sphere_radius', r_sphere_radius, ierr)
+ if (ierr /= MPAS_STREAM_NOERR) then
+ write(0,*) 'Warning: Attribute sphere_radius not found in '//trim(input_obj % filename)
+ write(0,*) ' Setting sphere_radius to 1.0'
+ domain % blocklist % mesh % sphere_radius = 1.0
+ else
+ domain % blocklist % mesh % sphere_radius = r_sphere_radius
+ end if
+
+ call MPAS_readStreamAtt(input_obj % io_stream, 'on_a_sphere', c_on_a_sphere, ierr)
+ if (ierr /= MPAS_STREAM_NOERR) then
+ write(0,*) 'Warning: Attribute on_a_sphere not found in '//trim(input_obj % filename)
+ write(0,*) ' Setting on_a_sphere to ''YES'''
domain % blocklist % mesh % on_a_sphere = .true.
else
- domain % blocklist % mesh % on_a_sphere = .false.
+ if (index(c_on_a_sphere, 'YES') /= 0) then
+ domain % blocklist % mesh % on_a_sphere = .true.
+ else
+ domain % blocklist % mesh % on_a_sphere = .false.
+ end if
end if
- domain % blocklist % mesh % sphere_radius = r_sphere_radius
if (.not. config_do_restart) then
input_obj % time = 1
else
- input_obj % time = 1
-
!
! If doing a restart, we need to decide which time slice to read from the
! restart file
!
- if (input_obj % rdLocalTime <= 0) then
- write(0,*) 'Error: Couldn''t find any times in restart file.'
+ input_obj % time = MPAS_seekStream(input_obj % io_stream, config_start_time, MPAS_STREAM_EXACT_TIME, timeStamp, ierr)
+ if (ierr == MPAS_IO_ERR) then
+ write(0,*) 'Error: restart file '//trim(filename)//' did not contain time '//trim(config_start_time)
call mpas_dmpar_abort(domain % dminfo)
end if
- if (domain % dminfo % my_proc_id == IO_NODE) then
- allocate(xtime % ioinfo)
- xtime % ioinfo % start(1) = 1
- xtime % ioinfo % count(1) = input_obj % rdLocalTime
- allocate(xtime % array(input_obj % rdLocalTime))
-
- xtime % ioinfo % fieldName = 'xtime'
- call mpas_io_input_field(input_obj, xtime)
-
- call mpas_set_timeInterval(interval=minTimeDiff, DD=10000)
- call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time)
-
- do i=1,input_obj % rdLocalTime
- call mpas_set_time(curr_time=sliceTime, dateTimeString=xtime % array(i))
- timeDiff = abs(sliceTime - startTime)
- if (timeDiff < minTimeDiff) then
- minTimeDiff = timeDiff
- input_obj % time = i
- end if
- end do
-
- ! require restart time to exactly match start time (this error should never be reached as we have by this point opened the restart file with a name containing the startTime)
- if(sliceTime /= startTime) then
- write(0,*) "Error: restart file ", filename, " did not contain time ", config_start_time
- call mpas_dmpar_abort(domain % dminfo)
- end if
-
- timeStamp = xtime % array(input_obj % time)
-
- deallocate(xtime % ioinfo)
- deallocate(xtime % array)
- end if
-
- call mpas_dmpar_bcast_int(domain % dminfo, input_obj % time)
- call mpas_dmpar_bcast_char(domain % dminfo, timeStamp)
-
+write(0,*) 'MGD DEBUGGING time = ', input_obj % time
write(0,*) 'Restarting model from time ', timeStamp
end if
@@ -810,17 +975,130 @@
! processes that own those indices based on
! {send,recv}{Cell,Edge,Vertex,VertLevel}List
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- call mpas_read_and_distribute_fields(domain % dminfo, input_obj, domain % blocklist, &
- readCellStart, nReadCells, readEdgeStart, nReadEdges, readVertexStart, nReadVertices, &
- readVertLevelStart, nReadVertLevels, &
- sendCellList, recvCellList, sendEdgeList, recvEdgeList, sendVertexList, recvVertexList, &
- sendVertLevelList, recvVertLevelList)
+ call mpas_read_and_distribute_fields(input_obj)
-
call mpas_io_input_finalize(input_obj, domain % dminfo)
+ call MPAS_io_close(inputHandle, ierr)
+
!
+ ! Work out halo exchange lists for cells, edges, and vertices
+ ! NB: The next pointer in each element of, e.g., cellsToSend, acts as the head pointer of
+ ! the list, since Fortran does not allow arrays of pointers
+ !
+
+ !--------- Create Cell Exchange Lists ---------!
+
+ ! pass in neededList of ownedCells and halo layer 1 cells
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ nOwnCells, nCellsCumulative(2), &
+ block_graph_2Halo % vertexID(1:nOwnCells), block_graph_2Halo % vertexID(1 : nCellsCumulative(2)), &
+ domain % blocklist % parinfo % cellsToSend(1) % next, domain % blocklist % parinfo % cellsToRecv(1) % next)
+
+ ! pass in neededList of ownedCells and halo layer 2 cells; offset of number of halo 1 cells is required
+ offset = nCellsHalo(1)
+ nTempIDs = nOwnCells + nCellsHalo(2)
+ allocate(tempIDs(nTempIDs))
+ tempIDs(1:nOwnCells) = block_graph_2Halo % vertexID(1:nOwnCells)
+ tempIDs(nOwnCells+1:nTempIDs) = block_graph_2Halo % vertexID(nCellsCumulative(2)+1 : nCellsCumulative(3))
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ nOwnCells, nTempIDs, &
+ block_graph_2Halo % vertexID(1:nOwnCells), tempIDs, &
+ domain % blocklist % parinfo % cellsToSend(2) % next, domain % blocklist % parinfo % cellsToRecv(2) % next, &
+ offset)
+ deallocate(tempIDs)
+
+
+ !--------- Create Edge Exchange Lists ---------!
+
+ ! pass in neededList of ownedEdges and ownedCell perimeter edges
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ nOwnEdges, nEdgesCumulative(2), &
+ local_edge_list(1:nOwnEdges), local_edge_list(1 : nEdgesCumulative(2)), &
+ domain % blocklist % parinfo % edgesToSend(1) % next, domain % blocklist % parinfo % edgesToRecv(1) % next)
+
+ ! pass in neededList of owned edges and yet-to-be-included edges from halo 1 cells; offset of number of ownedCell perimeter edges is required
+ offset = nEdgesHalo(1)
+ nTempIDs = nOwnEdges + nEdgesHalo(2)
+ allocate(tempIDs(nTempIDs))
+ tempIDs(1:nOwnEdges) = local_edge_list(1:nOwnEdges)
+ tempIDs(nOwnEdges+1:nTempIDs) = local_edge_list(nEdgesCumulative(2)+1 : nEdgesCumulative(3))
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ nOwnEdges, nTempIDs, &
+ local_edge_list(1:nOwnEdges), tempIDs, &
+ domain % blocklist % parinfo % edgesToSend(2) % next, domain % blocklist % parinfo % edgesToRecv(2) % next, &
+ offset)
+ deallocate(tempIDs)
+
+ ! pass in neededList of owned edges and yet-to-be-included edges from halo 2 cells; offset of number of ownedCell perimeter edges and halo 1 edges is required
+ offset = nEdgesHalo(1) + nEdgesHalo(2)
+ nTempIDs = nOwnEdges + nEdgesHalo(3)
+ allocate(tempIDs(nTempIDs))
+ tempIDs(1:nOwnEdges) = local_edge_list(1:nOwnEdges)
+ tempIDs(nOwnEdges+1:nTempIDs) = local_edge_list(nEdgesCumulative(3)+1 : nEdgesCumulative(4))
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ nOwnEdges, nTempIDs, &
+ local_edge_list(1:nOwnEdges), tempIDs, &
+ domain % blocklist % parinfo % edgesToSend(3) % next, domain % blocklist % parinfo % edgesToRecv(3) % next, &
+ offset)
+ deallocate(tempIDs)
+
+
+ !--------- Create Vertex Exchange Lists ---------!
+
+
+ ! pass in neededList of ownedVertices and ownedCell perimeter vertices
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ nOwnVertices, nVerticesCumulative(2), &
+ local_vertex_list(1:nOwnVertices), local_vertex_list(1 : nVerticesCumulative(2)), &
+ domain % blocklist % parinfo % verticesToSend(1) % next, domain % blocklist % parinfo % verticesToRecv(1) % next)
+
+ ! pass in neededList of owned vertices and yet-to-be-included vertices from halo 1 cells; offset of number of ownedCell perimeter vertices is required
+ offset = nVerticesHalo(1)
+ nTempIDs = nOwnVertices + nVerticesHalo(2)
+ allocate(tempIDs(nTempIDs))
+ tempIDs(1:nOwnVertices) = local_vertex_list(1:nOwnVertices)
+ tempIDs(nOwnVertices+1:nTempIDs) = local_vertex_list(nVerticesCumulative(2)+1 : nVerticesCumulative(3))
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ nOwnVertices, nTempIDs, &
+ local_vertex_list(1:nOwnVertices), tempIDs, &
+ domain % blocklist % parinfo % verticesToSend(2) % next, domain % blocklist % parinfo % verticesToRecv(2) % next, &
+ offset)
+ deallocate(tempIDs)
+
+ ! pass in neededList of owned vertices and yet-to-be-included vertices from halo 2 cells; offset of number of ownedCell perimeter vertices and halo 1 vertices is required
+ offset = nVerticesHalo(1) + nVerticesHalo(2)
+ nTempIDs = nOwnVertices + nVerticesHalo(3)
+ allocate(tempIDs(nTempIDs))
+ tempIDs(1:nOwnVertices) = local_vertex_list(1:nOwnVertices)
+ tempIDs(nOwnVertices+1:nTempIDs) = local_vertex_list(nVerticesCumulative(3)+1 : nVerticesCumulative(4))
+ call mpas_dmpar_get_owner_list(domain % dminfo, &
+ nOwnVertices, nTempIDs, &
+ local_vertex_list(1:nOwnVertices), tempIDs, &
+ domain % blocklist % parinfo % verticesToSend(3) % next, domain % blocklist % parinfo % verticesToRecv(3) % next, &
+ offset)
+ deallocate(tempIDs)
+
+
+ domain % blocklist % mesh % nCellsSolve = nOwnCells
+ domain % blocklist % mesh % nEdgesSolve = nOwnEdges
+ domain % blocklist % mesh % nVerticesSolve = ghostVertexStart-1
+ domain % blocklist % mesh % nVertLevelsSolve = domain % blocklist % mesh % nVertLevels ! No vertical decomp yet...
+
+ ! Link the sendList and recvList pointers in each field type to the appropriate lists
+ ! in parinfo, e.g., cellsToSend and cellsToRecv; in future, it can also be extended to
+ ! link blocks of fields to eachother
+ call mpas_create_field_links(domain % blocklist)
+
+
+ !
+ ! Exchange halos for all of the fields that were read from the input file
+ !
+ call mpas_exch_input_field_halos(domain, input_obj)
+
+
+ !
! Rename vertices in cellsOnCell, edgesOnCell, etc. to local indices
!
allocate(cellIDSorted(2,domain % blocklist % mesh % nCells))
@@ -855,7 +1133,6 @@
domain % blocklist % mesh % cellsOnCell % array(j,i) = cellIDSorted(2,k)
else
domain % blocklist % mesh % cellsOnCell % array(j,i) = domain % blocklist % mesh % nCells + 1
-! domain % blocklist % mesh % cellsOnCell % array(j,i) = 0
end if
k = mpas_binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
@@ -864,7 +1141,6 @@
domain % blocklist % mesh % edgesOnCell % array(j,i) = edgeIDSorted(2,k)
else
domain % blocklist % mesh % edgesOnCell % array(j,i) = domain % blocklist % mesh % nEdges + 1
-! domain % blocklist % mesh % edgesOnCell % array(j,i) = 0
end if
k = mpas_binary_search(vertexIDSorted, 2, 1, domain % blocklist % mesh % nVertices, &
@@ -873,7 +1149,6 @@
domain % blocklist % mesh % verticesOnCell % array(j,i) = vertexIDSorted(2,k)
else
domain % blocklist % mesh % verticesOnCell % array(j,i) = domain % blocklist % mesh % nVertices + 1
-! domain % blocklist % mesh % verticesOnCell % array(j,i) = 0
end if
end do
@@ -888,7 +1163,6 @@
domain % blocklist % mesh % cellsOnEdge % array(j,i) = cellIDSorted(2,k)
else
domain % blocklist % mesh % cellsOnEdge % array(j,i) = domain % blocklist % mesh % nCells + 1
-! domain % blocklist % mesh % cellsOnEdge % array(j,i) = 0
end if
k = mpas_binary_search(vertexIDSorted, 2, 1, domain % blocklist % mesh % nVertices, &
@@ -897,7 +1171,6 @@
domain % blocklist % mesh % verticesOnEdge % array(j,i) = vertexIDSorted(2,k)
else
domain % blocklist % mesh % verticesOnEdge % array(j,i) = domain % blocklist % mesh % nVertices + 1
-! domain % blocklist % mesh % verticesOnEdge % array(j,i) = 0
end if
end do
@@ -910,7 +1183,6 @@
domain % blocklist % mesh % edgesOnEdge % array(j,i) = edgeIDSorted(2,k)
else
domain % blocklist % mesh % edgesOnEdge % array(j,i) = domain % blocklist % mesh % nEdges + 1
-! domain % blocklist % mesh % edgesOnEdge % array(j,i) = 0
end if
end do
@@ -925,7 +1197,6 @@
domain % blocklist % mesh % cellsOnVertex % array(j,i) = cellIDSorted(2,k)
else
domain % blocklist % mesh % cellsOnVertex % array(j,i) = domain % blocklist % mesh % nCells + 1
-! domain % blocklist % mesh % cellsOnVertex % array(j,i) = 0
end if
k = mpas_binary_search(edgeIDSorted, 2, 1, domain % blocklist % mesh % nEdges, &
@@ -934,7 +1205,6 @@
domain % blocklist % mesh % edgesOnVertex % array(j,i) = edgeIDSorted(2,k)
else
domain % blocklist % mesh % edgesOnVertex % array(j,i) = domain % blocklist % mesh % nEdges + 1
-! domain % blocklist % mesh % edgesOnVertex % array(j,i) = 0
end if
end do
@@ -944,30 +1214,6 @@
deallocate(edgeIDSorted)
deallocate(vertexIDSorted)
-
- !
- ! Work out halo exchange lists for cells, edges, and vertices
- !
- call mpas_dmpar_get_owner_list(domain % dminfo, &
- block_graph_2Halo % nVertices, block_graph_2Halo % nVerticesTotal, &
- block_graph_2Halo % vertexID(1:block_graph_2Halo % nVertices), block_graph_2Halo % vertexID, &
- domain % blocklist % parinfo % cellsToSend, domain % blocklist % parinfo % cellsToRecv)
-
- call mpas_dmpar_get_owner_list(domain % dminfo, &
- ghostEdgeStart-1, nlocal_edges, &
- local_edge_list(1:ghostEdgeStart-1), local_edge_list, &
- domain % blocklist % parinfo % edgesToSend, domain % blocklist % parinfo % edgesToRecv)
-
- call mpas_dmpar_get_owner_list(domain % dminfo, &
- ghostVertexStart-1, nlocal_vertices, &
- local_vertex_list(1:ghostVertexStart-1), local_vertex_list, &
- domain % blocklist % parinfo % verticesToSend, domain % blocklist % parinfo % verticesToRecv)
-
- domain % blocklist % mesh % nCellsSolve = block_graph_2Halo % nVertices
- domain % blocklist % mesh % nEdgesSolve = ghostEdgeStart-1
- domain % blocklist % mesh % nVerticesSolve = ghostVertexStart-1
- domain % blocklist % mesh % nVertLevelsSolve = domain % blocklist % mesh % nVertLevels ! No vertical decomp yet...
-
!
! Deallocate fields, graphs, and other memory
@@ -1003,6 +1249,7 @@
deallocate(indexToCellID_0Halo)
deallocate(cellsOnEdge_2Halo)
deallocate(cellsOnVertex_2Halo)
+ deallocate(nEdgesOnCell_2Halo)
deallocate(edgesOnCell_2Halo)
deallocate(verticesOnCell_2Halo)
deallocate(block_graph_0Halo % vertexID)
@@ -1038,92 +1285,41 @@
end if
end do
+ do i=1,len_trim(filename)
+ if (filename(i:i) == ':') filename(i:i) = '.'
+ end do
+
end subroutine mpas_insert_string_suffix
- subroutine mpas_read_and_distribute_fields(dminfo, input_obj, block, &
- readCellsStart, readCellsCount, &
- readEdgesStart, readEdgesCount, &
- readVerticesStart, readVerticesCount, &
- readVertLevelsStart, readVertLevelsCount, &
- sendCellsList, recvCellsList, &
- sendEdgesList, recvEdgesList, &
- sendVerticesList, recvVerticesList, &
- sendVertLevelsList, recvVertLevelsList)
+ subroutine mpas_read_and_distribute_fields(input_obj)
implicit none
- type (dm_info), intent(in) :: dminfo
- type (io_input_object), intent(in) :: input_obj
- type (block_type), intent(inout) :: block
- integer, intent(in) :: readCellsStart, readCellsCount, readEdgesStart, readEdgesCount, readVerticesStart, readVerticesCount
- integer, intent(in) :: readVertLevelsStart, readVertLevelsCount
- type (exchange_list), pointer :: sendCellsList, recvCellsList
- type (exchange_list), pointer :: sendEdgesList, recvEdgesList
- type (exchange_list), pointer :: sendVerticesList, recvVerticesList
- type (exchange_list), pointer :: sendVertLevelsList, recvVertLevelsList
+ type (io_input_object), intent(inout) :: input_obj
- type (field1dInteger) :: int1d
- type (field2dInteger) :: int2d
- type (field0dReal) :: real0d
- type (field1dReal) :: real1d
- type (field2dReal) :: real2d
- type (field3dReal) :: real3d
- type (field0dChar) :: char0d
- type (field1dChar) :: char1d
+ integer :: ierr
- integer :: i1, i2, i3, i4
- integer, dimension(:), pointer :: super_int1d
- integer, dimension(:,:), pointer :: super_int2d
- real (kind=RKIND) :: super_real0d
- real (kind=RKIND), dimension(:), pointer :: super_real1d
- real (kind=RKIND), dimension(:,:), pointer :: super_real2d
- real (kind=RKIND), dimension(:,:,:), pointer :: super_real3d
- character (len=64) :: super_char0d
- character (len=64), dimension(:), pointer :: super_char1d
+ call MPAS_readStream(input_obj % io_stream, 1, ierr)
- integer :: i, k
-#include "nondecomp_dims.inc"
-
- allocate(int1d % ioinfo)
- allocate(int2d % ioinfo)
- allocate(real0d % ioinfo)
- allocate(real1d % ioinfo)
- allocate(real2d % ioinfo)
- allocate(real3d % ioinfo)
- allocate(char0d % ioinfo)
- allocate(char1d % ioinfo)
-
-
-#include "io_input_fields.inc"
-
-#include "nondecomp_dims_dealloc.inc"
-
end subroutine mpas_read_and_distribute_fields
- subroutine mpas_io_input_init(input_obj, dminfo)
+ subroutine mpas_io_input_init(input_obj, blocklist, dminfo)
implicit none
type (io_input_object), intent(inout) :: input_obj
+ type (block_type), intent(in) :: blocklist
type (dm_info), intent(in) :: dminfo
- include 'netcdf.inc'
-
integer :: nferr
-
-#ifdef OFFSET64BIT
- nferr = nf_open(trim(input_obj % filename), ior(NF_SHARE,NF_64BIT_OFFSET), input_obj % rd_ncid)
-#else
- nferr = nf_open(trim(input_obj % filename), NF_SHARE, input_obj % rd_ncid)
-#endif
-
- if (nferr /= NF_NOERR) then
+ call MPAS_createStream(input_obj % io_stream, trim(input_obj % filename), MPAS_IO_PNETCDF, MPAS_IO_READ, 1, nferr)
+ if (nferr /= MPAS_STREAM_NOERR) then
write(0,*) ' '
if (input_obj % stream == STREAM_RESTART) then
write(0,*) 'Error opening restart file ''', trim(input_obj % filename), ''''
@@ -1135,9 +1331,9 @@
write(0,*) ' '
call mpas_dmpar_abort(dminfo)
end if
-
-#include "netcdf_read_ids.inc"
+#include "add_input_fields.inc"
+
end subroutine mpas_io_input_init
@@ -1149,7 +1345,7 @@
character (len=*), intent(in) :: dimname
integer, intent(out) :: dimsize
-#include "get_dimension_by_name.inc"
+!include "get_dimension_by_name.inc"
end subroutine mpas_io_input_get_dimension
@@ -1162,24 +1358,8 @@
character (len=*), intent(in) :: attname
real (kind=RKIND), intent(out) :: attvalue
- include 'netcdf.inc'
-
integer :: nferr
- if (RKIND == 8) then
- nferr = nf_get_att_double(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
- else
- nferr = nf_get_att_real(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
- end if
- if (nferr /= NF_NOERR) then
- write(0,*) 'Warning: Attribute '//trim(attname)//&
- ' not found in '//trim(input_obj % filename)
- if (index(attname, 'sphere_radius') /= 0) then
- write(0,*) ' Setting '//trim(attname)//' to 1.0'
- attvalue = 1.0
- end if
- end if
-
end subroutine mpas_io_input_get_att_real
@@ -1191,448 +1371,23 @@
character (len=*), intent(in) :: attname
character (len=*), intent(out) :: attvalue
- include 'netcdf.inc'
-
integer :: nferr
- nferr = nf_get_att_text(input_obj % rd_ncid, NF_GLOBAL, attname, attvalue)
- if (nferr /= NF_NOERR) then
- write(0,*) 'Warning: Attribute '//trim(attname)//&
- ' not found in '//trim(input_obj % filename)
- if (index(attname, 'on_a_sphere') /= 0) then
- write(0,*) ' Setting '//trim(attname)//' to ''YES'''
- attvalue = 'YES'
- end if
- end if
-
end subroutine mpas_io_input_get_att_text
- subroutine mpas_io_input_field0d_real(input_obj, field)
-
- implicit none
+ subroutine mpas_exch_input_field_halos(domain, input_obj)
- type (io_input_object), intent(in) :: input_obj
- type (field0dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = 1
- count1(1) = 1
-
-#include "input_field0dreal.inc"
-
-#if SINGLE_PRECISION
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#endif
-
- end subroutine mpas_io_input_field0d_real
-
-
- subroutine mpas_io_input_field1d_real(input_obj, field)
-
implicit none
- type (io_input_object), intent(in) :: input_obj
- type (field1dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = field % ioinfo % start(1)
- count1(1) = field % ioinfo % count(1)
+ type (domain_type), intent(inout) :: domain
+ type (io_input_object), intent(inout) :: input_obj
- !
- ! Special case: we may want to read the xtime variable across the
- ! time dimension as a 1d array.
- !
- if (trim(field % ioinfo % fieldName) == 'xtime') then
- varID = input_obj % rdVarIDxtime
- end if
-
-#include "input_field1dreal.inc"
+#include "exchange_input_field_halos.inc"
-#if SINGLE_PRECISION
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % array)
-#else
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % array)
-#endif
-
- end subroutine mpas_io_input_field1d_real
+ end subroutine mpas_exch_input_field_halos
- subroutine mpas_io_input_field2d_real(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field2dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = field % ioinfo % start(2)
- count2(1) = field % ioinfo % count(1)
- count2(2) = field % ioinfo % count(2)
-
-#include "input_field2dreal.inc"
-
-#if SINGLE_PRECISION
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
-#endif
-
- end subroutine mpas_io_input_field2d_real
-
-
- subroutine mpas_io_input_field3d_real(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field3dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start3, count3
-
- start3(1) = field % ioinfo % start(1)
- start3(2) = field % ioinfo % start(2)
- start3(3) = field % ioinfo % start(3)
- count3(1) = field % ioinfo % count(1)
- count3(2) = field % ioinfo % count(2)
- count3(3) = field % ioinfo % count(3)
-
-#include "input_field3dreal.inc"
-
-#if SINGLE_PRECISION
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
-#endif
-
- end subroutine mpas_io_input_field3d_real
-
-
- subroutine mpas_io_input_field0d_real_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field0dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = input_obj % time
- count1(1) = 1
-
-#include "input_field0dreal_time.inc"
-
-#if SINGLE_PRECISION
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#endif
-
- end subroutine mpas_io_input_field0d_real_time
-
-
- subroutine mpas_io_input_field1d_real_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = input_obj % time
- count2(1) = field % ioinfo % count(1)
- count2(2) = 1
-
-#include "input_field1dreal_time.inc"
-
-#if SINGLE_PRECISION
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
-#endif
-
- end subroutine mpas_io_input_field1d_real_time
-
-
- subroutine mpas_io_input_field2d_real_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field2dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start3, count3
-
- start3(1) = field % ioinfo % start(1)
- start3(2) = field % ioinfo % start(2)
- start3(3) = input_obj % time
- count3(1) = field % ioinfo % count(1)
- count3(2) = field % ioinfo % count(2)
- count3(3) = 1
-
-#include "input_field2dreal_time.inc"
-
-#if SINGLE_PRECISION
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
-#endif
-
- end subroutine mpas_io_input_field2d_real_time
-
-
- subroutine mpas_io_input_field3d_real_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field3dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(4) :: start4, count4
-
- start4(1) = field % ioinfo % start(1)
- start4(2) = field % ioinfo % start(2)
- start4(3) = field % ioinfo % start(3)
- start4(4) = input_obj % time
- count4(1) = field % ioinfo % count(1)
- count4(2) = field % ioinfo % count(2)
- count4(3) = field % ioinfo % count(3)
- count4(4) = 1
-
-#include "input_field3dreal_time.inc"
-
-#if SINGLE_PRECISION
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start4, count4, field % array)
-#else
- nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start4, count4, field % array)
-#endif
-
- end subroutine mpas_io_input_field3d_real_time
-
-
- subroutine mpas_io_input_field1d_integer(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = field % ioinfo % start(1)
- count1(1) = field % ioinfo % count(1)
-
-#include "input_field1dinteger.inc"
-
- nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start1, count1, field % array)
-
- end subroutine mpas_io_input_field1d_integer
-
-
- subroutine mpas_io_input_field2d_integer(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field2dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = field % ioinfo % start(2)
- count2(1) = field % ioinfo % count(1)
- count2(2) = field % ioinfo % count(2)
-
-#include "input_field2dinteger.inc"
-
- nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start2, count2, field % array)
-
- end subroutine mpas_io_input_field2d_integer
-
-
- subroutine mpas_io_input_field1d_integer_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = input_obj % time
- count2(1) = field % ioinfo % count(1)
- count2(2) = 1
-
-#include "input_field1dinteger_time.inc"
-
- nferr = nf_get_vara_int(input_obj % rd_ncid, varID, start2, count2, field % array)
-
- end subroutine mpas_io_input_field1d_integer_time
-
-
- subroutine mpas_io_input_field0d_char_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field0dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = input_obj % time
- count1(2) = 1
-
-#include "input_field0dchar_time.inc"
-
- nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-
- end subroutine mpas_io_input_field0d_char_time
-
-
- subroutine mpas_io_input_field1d_char_time(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start2, count2
-
- start2(1) = 1
- start2(2) = field % ioinfo % start(1)
- start2(3) = input_obj % time
- count2(1) = 64
- count2(2) = field % ioinfo % count(1)
- count2(3) = 1
-
-#include "input_field1dchar_time.inc"
-
- nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start2, count2, field % array)
-
- end subroutine mpas_io_input_field1d_char_time
-
-
- subroutine mpas_io_input_field0d_char(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field0dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = 1
- count1(2) = 1
-
-#include "input_field0dchar.inc"
-
- nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-
- end subroutine mpas_io_input_field0d_char
-
-
- subroutine mpas_io_input_field1d_char(input_obj, field)
-
- implicit none
-
- type (io_input_object), intent(in) :: input_obj
- type (field1dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = field % ioinfo % start(1)
- count1(2) = field % ioinfo % count(1)
-
- !
- ! Special case: we may want to read the xtime variable across the
- ! time dimension as a 1d array.
- !
- if (trim(field % ioinfo % fieldName) == 'xtime') then
- varID = input_obj % rdVarIDxtime
- end if
-
-#include "input_field1dchar.inc"
-
- nferr = nf_get_vara_text(input_obj % rd_ncid, varID, start1, count1, field % array)
-
- end subroutine mpas_io_input_field1d_char
-
-
subroutine mpas_io_input_finalize(input_obj, dminfo)
implicit none
@@ -1640,11 +1395,9 @@
type (io_input_object), intent(inout) :: input_obj
type (dm_info), intent(in) :: dminfo
- include 'netcdf.inc'
-
integer :: nferr
- nferr = nf_close(input_obj % rd_ncid)
+ call MPAS_closeStream(input_obj % io_stream, nferr)
end subroutine mpas_io_input_finalize
Modified: trunk/mpas/src/framework/mpas_io_output.F
===================================================================
--- trunk/mpas/src/framework/mpas_io_output.F 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/framework/mpas_io_output.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -4,52 +4,22 @@
use mpas_dmpar
use mpas_sort
use mpas_configure
+ use mpas_io_streams
integer, parameter :: OUTPUT = 1
integer, parameter :: RESTART = 2
integer, parameter :: SFC = 3
type io_output_object
- integer :: wr_ncid
character (len=1024) :: filename
+ integer :: stream
integer :: time
- integer :: stream
-
- integer :: wrDimIDStrLen
-#include "io_output_obj_decls.inc"
-
- logical :: validExchangeLists
- type (exchange_list), pointer :: sendCellsList, recvCellsList
- type (exchange_list), pointer :: sendEdgesList, recvEdgesList
- type (exchange_list), pointer :: sendVerticesList, recvVerticesList
- type (exchange_list), pointer :: sendVertLevelsList, recvVertLevelsList
+ type (MPAS_Stream_type) :: io_stream
end type io_output_object
- interface mpas_io_output_field
- module procedure mpas_io_output_field0d_real
- module procedure mpas_io_output_field1d_real
- module procedure mpas_io_output_field2d_real
- module procedure mpas_io_output_field3d_real
- module procedure mpas_io_output_field1d_integer
- module procedure mpas_io_output_field2d_integer
- module procedure mpas_io_output_field0d_char
- module procedure mpas_io_output_field1d_char
- end interface mpas_io_output_field
-
- interface mpas_io_output_field_time
- module procedure mpas_io_output_field0d_real_time
- module procedure mpas_io_output_field1d_real_time
- module procedure mpas_io_output_field2d_real_time
- module procedure mpas_io_output_field3d_real_time
- module procedure mpas_io_output_field1d_integer_time
- module procedure mpas_io_output_field0d_char_time
- module procedure mpas_io_output_field1d_char_time
- end interface mpas_io_output_field_time
-
-
contains
@@ -65,26 +35,9 @@
character (len=128) :: tempfilename
type (block_type), pointer :: block_ptr
-#include "output_dim_actual_decls.inc"
block_ptr => domain % blocklist
- nullify(output_obj % sendCellsList)
- nullify(output_obj % recvCellsList)
- nullify(output_obj % sendEdgesList)
- nullify(output_obj % recvEdgesList)
- nullify(output_obj % sendVerticesList)
- nullify(output_obj % recvVerticesList)
- nullify(output_obj % sendVertLevelsList)
- nullify(output_obj % recvVertLevelsList)
- output_obj % validExchangeLists = .false.
-#include "output_dim_inits.inc"
-
- call mpas_dmpar_sum_int(domain % dminfo, block_ptr % mesh % nCellsSolve, nCellsGlobal)
- call mpas_dmpar_sum_int(domain % dminfo, block_ptr % mesh % nEdgesSolve, nEdgesGlobal)
- call mpas_dmpar_sum_int(domain % dminfo, block_ptr % mesh % nVerticesSolve, nVerticesGlobal)
- nVertLevelsGlobal = block_ptr % mesh % nVertLevels
-
if (trim(stream) == 'OUTPUT') then
if(present(outputSuffix)) then
call mpas_insert_string_suffix(config_output_name, outputSuffix, tempfilename)
@@ -109,9 +62,8 @@
! For now, we assume that a domain consists only of one block,
! although in future, work needs to be done to write model state
! from many distributed blocks
- call mpas_io_output_init(output_obj, domain % dminfo, &
- block_ptr % mesh, &
-#include "output_dim_actual_args.inc"
+ call mpas_io_output_init(domain, output_obj, domain % dminfo, &
+ block_ptr % mesh &
)
end subroutine mpas_output_state_init
@@ -136,6 +88,10 @@
end if
end do
+ do i=1,len_trim(filename)
+ if (filename(i:i) == ':') filename(i:i) = '.'
+ end do
+
end subroutine mpas_insert_string_suffix
@@ -147,15 +103,8 @@
type (domain_type), intent(inout) :: domain
integer, intent(in) :: itime
+ integer :: ierr
integer :: i, j
- integer :: nCellsGlobal
- integer :: nEdgesGlobal
- integer :: nVerticesGlobal
- integer :: nVertLevelsGlobal
- integer, dimension(:), pointer :: neededCellList
- integer, dimension(:), pointer :: neededEdgeList
- integer, dimension(:), pointer :: neededVertexList
- integer, dimension(:), pointer :: neededVertLevelList
integer, dimension(:,:), pointer :: cellsOnCell, edgesOnCell, verticesOnCell, &
cellsOnEdge, verticesOnEdge, edgesOnEdge, cellsOnVertex, edgesOnVertex
integer, dimension(:,:), pointer :: cellsOnCell_save, edgesOnCell_save, verticesOnCell_save, &
@@ -170,35 +119,8 @@
type (field0dChar) :: char0d
type (field1dChar) :: char1d
- integer :: i1, i2, i3, i4
-
- integer, dimension(:), pointer :: super_int1d
- integer, dimension(:,:), pointer :: super_int2d
- real (kind=RKIND) :: super_real0d
- real (kind=RKIND), dimension(:), pointer :: super_real1d
- real (kind=RKIND), dimension(:,:), pointer :: super_real2d
- real (kind=RKIND), dimension(:,:,:), pointer :: super_real3d
- character (len=64) :: super_char0d
- character (len=64), dimension(:), pointer :: super_char1d
-
-#include "nondecomp_outputs.inc"
-
output_obj % time = itime
- allocate(int1d % ioinfo)
- allocate(int2d % ioinfo)
- allocate(real0d % ioinfo)
- allocate(real1d % ioinfo)
- allocate(real2d % ioinfo)
- allocate(real3d % ioinfo)
- allocate(char0d % ioinfo)
- allocate(char1d % ioinfo)
-
- call mpas_dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nCellsSolve, nCellsGlobal)
- call mpas_dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nEdgesSolve, nEdgesGlobal)
- call mpas_dmpar_sum_int(domain % dminfo, domain % blocklist % mesh % nVerticesSolve, nVerticesGlobal)
- nVertLevelsGlobal = domain % blocklist % mesh % nVertLevels
-
allocate(cellsOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
allocate(edgesOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
allocate(verticesOnCell(domain % blocklist % mesh % maxEdges, domain % blocklist % mesh % nCellsSolve))
@@ -259,58 +181,6 @@
end do
end do
- if (domain % dminfo % my_proc_id == 0) then
- allocate(neededCellList(nCellsGlobal))
- allocate(neededEdgeList(nEdgesGlobal))
- allocate(neededVertexList(nVerticesGlobal))
- allocate(neededVertLevelList(nVertLevelsGlobal))
- do i=1,nCellsGlobal
- neededCellList(i) = i
- end do
- do i=1,nEdgesGlobal
- neededEdgeList(i) = i
- end do
- do i=1,nVerticesGlobal
- neededVertexList(i) = i
- end do
- do i=1,nVertLevelsGlobal
- neededVertLevelList(i) = i
- end do
- else
- allocate(neededCellList(0))
- allocate(neededEdgeList(0))
- allocate(neededVertexList(0))
- allocate(neededVertLevelList(0))
- end if
-
- if (.not. output_obj % validExchangeLists) then
- call mpas_dmpar_get_owner_list(domain % dminfo, &
- domain % blocklist % mesh % nCellsSolve, size(neededCellList), &
- domain % blocklist % mesh % indexToCellID % array, neededCellList, &
- output_obj % sendCellsList, output_obj % recvCellsList)
-
- call mpas_dmpar_get_owner_list(domain % dminfo, &
- domain % blocklist % mesh % nEdgesSolve, size(neededEdgeList), &
- domain % blocklist % mesh % indexToEdgeID % array, neededEdgeList, &
- output_obj % sendEdgesList, output_obj % recvEdgesList)
-
- call mpas_dmpar_get_owner_list(domain % dminfo, &
- domain % blocklist % mesh % nVerticesSolve, size(neededVertexList), &
- domain % blocklist % mesh % indexToVertexID % array, neededVertexList, &
- output_obj % sendVerticesList, output_obj % recvVerticesList)
-
- call mpas_dmpar_get_owner_list(domain % dminfo, &
- size(neededVertLevelList), size(neededVertLevelList), &
- neededVertLevelList, neededVertLevelList, &
- output_obj % sendVertLevelsList, output_obj % recvVertLevelsList)
-
- output_obj % validExchangeLists = .true.
- end if
-
- deallocate(neededCellList)
- deallocate(neededEdgeList)
- deallocate(neededVertexList)
-
cellsOnCell_save => domain % blocklist % mesh % cellsOnCell % array
edgesOnCell_save => domain % blocklist % mesh % edgesOnCell % array
verticesOnCell_save => domain % blocklist % mesh % verticesOnCell % array
@@ -329,7 +199,7 @@
domain % blocklist % mesh % cellsOnVertex % array => cellsOnVertex
domain % blocklist % mesh % edgesOnVertex % array => edgesOnVertex
-#include "io_output_fields.inc"
+ call MPAS_writeStream(output_obj % io_stream, output_obj % time, ierr)
domain % blocklist % mesh % cellsOnCell % array => cellsOnCell_save
domain % blocklist % mesh % edgesOnCell % array => edgesOnCell_save
@@ -349,8 +219,6 @@
deallocate(cellsOnVertex)
deallocate(edgesOnVertex)
-#include "nondecomp_outputs_dealloc.inc"
-
end subroutine mpas_output_state_for_domain
@@ -366,504 +234,47 @@
end subroutine mpas_output_state_finalize
- subroutine mpas_io_output_init( output_obj, &
+ subroutine mpas_io_output_init( domain, output_obj, &
dminfo, &
- mesh, &
-#include "dim_dummy_args.inc"
+ mesh &
)
implicit none
- include 'netcdf.inc'
-
+ type (domain_type), intent(in) :: domain
type (io_output_object), intent(inout) :: output_obj
type (dm_info), intent(in) :: dminfo
type (mesh_type), intent(in) :: mesh
-#include "dim_dummy_decls.inc"
- integer :: nferr
+ integer :: nferr, ierr
integer, dimension(10) :: dimlist
- if (dminfo % my_proc_id == 0) then
-#ifdef OFFSET64BIT
- nferr = nf_create(trim(output_obj % filename), ior(NF_CLOBBER,NF_64BIT_OFFSET), output_obj % wr_ncid)
-#else
- nferr = nf_create(trim(output_obj % filename), NF_CLOBBER, output_obj % wr_ncid)
-#endif
-
- nferr = nf_def_dim(output_obj % wr_ncid, 'StrLen', 64, output_obj % wrDimIDStrLen)
-#include "netcdf_def_dims_vars.inc"
+ call MPAS_createStream(output_obj % io_stream, trim(output_obj % filename), MPAS_IO_PNETCDF, MPAS_IO_WRITE, 1, nferr)
+#include "add_output_fields.inc"
+
if (mesh % on_a_sphere) then
- nferr = nf_put_att_text(output_obj % wr_ncid, NF_GLOBAL, 'on_a_sphere', 16, 'YES ')
+ call MPAS_writeStreamAtt(output_obj % io_stream, 'on_a_sphere', 'YES ', nferr)
else
- nferr = nf_put_att_text(output_obj % wr_ncid, NF_GLOBAL, 'on_a_sphere', 16, 'NO ')
+ call MPAS_writeStreamAtt(output_obj % io_stream, 'on_a_sphere', 'NO ', nferr)
end if
- if (RKIND == 8) then
- nferr = nf_put_att_double(output_obj % wr_ncid, NF_GLOBAL, 'sphere_radius', NF_DOUBLE, 1, mesh % sphere_radius)
- else
- nferr = nf_put_att_real(output_obj % wr_ncid, NF_GLOBAL, 'sphere_radius', NF_FLOAT, 1, mesh % sphere_radius)
- end if
+ call MPAS_writeStreamAtt(output_obj % io_stream, 'sphere_radius', mesh % sphere_radius, nferr)
+
+#include "add_output_atts.inc"
- nferr = nf_enddef(output_obj % wr_ncid)
- end if
-
end subroutine mpas_io_output_init
- subroutine mpas_io_output_field0d_real(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field0dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = 1
- count1(1) = 1
-
-#include "output_field0dreal.inc"
-
-#ifdef SINGLE_PRECISION
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field0d_real
-
-
- subroutine mpas_io_output_field1d_real(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = field % ioinfo % start(1)
- count1(1) = field % ioinfo % count(1)
-
-#include "output_field1dreal.inc"
-
-#ifdef SINGLE_PRECISION
- nferr = nf_put_vara_real(output_obj % wr_ncid, VarID, start1, count1, field % array)
-#else
- nferr = nf_put_vara_double(output_obj % wr_ncid, VarID, start1, count1, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field1d_real
-
-
- subroutine mpas_io_output_field2d_real(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field2dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = field % ioinfo % start(2)
- count2(1) = field % ioinfo % count(1)
- count2(2) = field % ioinfo % count(2)
-
-#include "output_field2dreal.inc"
-
-#ifdef SINGLE_PRECISION
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field2d_real
-
-
- subroutine mpas_io_output_field3d_real(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field3dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start3, count3
-
- start3(1) = field % ioinfo % start(1)
- start3(2) = field % ioinfo % start(2)
- start3(3) = field % ioinfo % start(3)
- count3(1) = field % ioinfo % count(1)
- count3(2) = field % ioinfo % count(2)
- count3(3) = field % ioinfo % count(3)
-
-#include "output_field3dreal.inc"
-
-#ifdef SINGLE_PRECISION
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field3d_real
-
-
- subroutine mpas_io_output_field0d_real_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field0dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = output_obj % time
- count1(1) = 1
-
-#include "output_field0dreal_time.inc"
-
-#ifdef SINGLE_PRECISION
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field0d_real_time
-
-
- subroutine mpas_io_output_field1d_real_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = output_obj % time
- count2(1) = field % ioinfo % count(1)
- count2(2) = 1
-
-#include "output_field1dreal_time.inc"
-
-#ifdef SINGLE_PRECISION
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field1d_real_time
-
-
- subroutine mpas_io_output_field2d_real_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field2dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start3, count3
-
- start3(1) = field % ioinfo % start(1)
- start3(2) = field % ioinfo % start(2)
- start3(3) = output_obj % time
- count3(1) = field % ioinfo % count(1)
- count3(2) = field % ioinfo % count(2)
- count3(3) = 1
-
-#include "output_field2dreal_time.inc"
-
-#ifdef SINGLE_PRECISION
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field2d_real_time
-
-
- subroutine mpas_io_output_field3d_real_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field3dReal), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(4) :: start4, count4
-
- start4(1) = field % ioinfo % start(1)
- start4(2) = field % ioinfo % start(2)
- start4(3) = field % ioinfo % start(3)
- start4(4) = output_obj % time
- count4(1) = field % ioinfo % count(1)
- count4(2) = field % ioinfo % count(2)
- count4(3) = field % ioinfo % count(3)
- count4(4) = 1
-
-#include "output_field3dreal_time.inc"
-
-#ifdef SINGLE_PRECISION
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start4, count4, field % array)
-#else
- nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start4, count4, field % array)
-#endif
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field3d_real_time
-
-
- subroutine mpas_io_output_field1d_integer(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(1) :: start1, count1
-
- start1(1) = field % ioinfo % start(1)
- count1(1) = field % ioinfo % count(1)
-
-#include "output_field1dinteger.inc"
-
- nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start1, count1, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field1d_integer
-
-
- subroutine mpas_io_output_field2d_integer(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field2dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = field % ioinfo % start(2)
- count2(1) = field % ioinfo % count(1)
- count2(2) = field % ioinfo % count(2)
-
-#include "output_field2dinteger.inc"
-
- nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start2, count2, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field2d_integer
-
-
- subroutine mpas_io_output_field1d_integer_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dInteger), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start2, count2
-
- start2(1) = field % ioinfo % start(1)
- start2(2) = output_obj % time
- count2(1) = field % ioinfo % count(1)
- count2(2) = 1
-
-#include "output_field1dinteger_time.inc"
-
- nferr = nf_put_vara_int(output_obj % wr_ncid, varID, start2, count2, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field1d_integer_time
-
-
- subroutine mpas_io_output_field0d_char_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field0dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = output_obj % time
- count1(2) = 1
-
-#include "output_field0dchar_time.inc"
-
- nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field0d_char_time
-
-
- subroutine mpas_io_output_field1d_char_time(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(3) :: start2, count2
-
- start2(1) = 1
- start2(2) = field % ioinfo % start(1)
- start2(3) = output_obj % time
- count2(1) = 64
- count2(2) = field % ioinfo % count(1)
- count2(3) = 1
-
-#include "output_field1dchar_time.inc"
-
- nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start2, count2, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field1d_char_time
-
-
- subroutine mpas_io_output_field0d_char(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field0dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = 1
- count1(2) = 1
-
-#include "output_field0dchar.inc"
-
- nferr = nf_put_vara_text(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field0d_char
-
-
- subroutine mpas_io_output_field1d_char(output_obj, field)
-
- implicit none
-
- type (io_output_object), intent(in) :: output_obj
- type (field1dChar), intent(inout) :: field
-
- include 'netcdf.inc'
-
- integer :: nferr
- integer :: varID
- integer, dimension(2) :: start1, count1
-
- start1(1) = 1
- count1(1) = 64
- start1(2) = field % ioinfo % start(1)
- count1(2) = field % ioinfo % count(1)
-
-#include "output_field1dchar.inc"
-
- nferr = nf_put_vara_text(output_obj % wr_ncid, VarID, start1, count1, field % array)
-
- nferr = nf_sync(output_obj % wr_ncid)
-
- end subroutine mpas_io_output_field1d_char
-
-
subroutine mpas_io_output_finalize(output_obj, dminfo)
implicit none
- include 'netcdf.inc'
-
type (io_output_object), intent(inout) :: output_obj
type (dm_info), intent(in) :: dminfo
integer :: nferr
- if (dminfo % my_proc_id == 0) then
- nferr = nf_close(output_obj % wr_ncid)
- end if
+ call MPAS_closeStream(output_obj % io_stream, nferr)
end subroutine mpas_io_output_finalize
Added: trunk/mpas/src/framework/mpas_io_streams.F
===================================================================
--- trunk/mpas/src/framework/mpas_io_streams.F (rev 0)
+++ trunk/mpas/src/framework/mpas_io_streams.F 2012-04-24 23:11:28 UTC (rev 1802)
@@ -0,0 +1,2761 @@
+module mpas_io_streams
+
+ use mpas_attlist
+ use mpas_grid_types
+ use mpas_timekeeping
+ use mpas_io
+
+ type field_list_type
+ integer :: field_type
+ logical :: isDecomposed
+ integer :: totalDimSize ! Total size of outer dimension across all blocks for decomposed fields
+ logical, dimension(:), pointer :: isAvailable => null() ! Used for reading super-arrays where one or more
+ ! constitutent arrays may not be present in the input file
+ type (field0dInteger), pointer :: int0dField => null()
+ type (field1dInteger), pointer :: int1dField => null()
+ type (field2dInteger), pointer :: int2dField => null()
+ type (field3dInteger), pointer :: int3dField => null()
+ type (field0dReal), pointer :: real0dField => null()
+ type (field1dReal), pointer :: real1dField => null()
+ type (field2dReal), pointer :: real2dField => null()
+ type (field3dReal), pointer :: real3dField => null()
+ type (field0dChar), pointer :: char0dField => null()
+ type (field1dChar), pointer :: char1dField => null()
+ type (field_list_type), pointer :: next => null()
+ end type field_list_type
+
+ type MPAS_Stream_type
+ logical :: isInitialized = .false.
+ integer :: ioFormat
+ integer :: ioDirection
+ integer :: framesPerFile
+ type (MPAS_IO_Handle_type) :: fileHandle
+ type (att_list_type), pointer :: attList => null()
+ type (field_list_type), pointer :: fieldList => null()
+ end type MPAS_Stream_type
+
+
+ interface MPAS_streamAddField
+ module procedure MPAS_streamAddField_0dInteger
+ module procedure MPAS_streamAddField_1dInteger
+ module procedure MPAS_streamAddField_2dInteger
+ module procedure MPAS_streamAddField_3dInteger
+ module procedure MPAS_streamAddField_0dReal
+ module procedure MPAS_streamAddField_1dReal
+ module procedure MPAS_streamAddField_2dReal
+ module procedure MPAS_streamAddField_3dReal
+ module procedure MPAS_streamAddField_0dChar
+ end interface MPAS_streamAddField
+
+ interface MPAS_readStreamAtt
+ module procedure MPAS_readStreamAtt_0dInteger
+ module procedure MPAS_readStreamAtt_1dInteger
+ module procedure MPAS_readStreamAtt_0dReal
+ module procedure MPAS_readStreamAtt_1dReal
+ module procedure MPAS_readStreamAtt_text
+ end interface MPAS_readStreamAtt
+
+ interface MPAS_writeStreamAtt
+ module procedure MPAS_writeStreamAtt_0dInteger
+ module procedure MPAS_writeStreamAtt_1dInteger
+ module procedure MPAS_writeStreamAtt_0dReal
+ module procedure MPAS_writeStreamAtt_1dReal
+ module procedure MPAS_writeStreamAtt_text
+ end interface MPAS_writeStreamAtt
+
+ integer, parameter :: MPAS_STREAM_EXACT_TIME = 100, &
+ MPAS_STREAM_NEAREST = 101, &
+ MPAS_STREAM_LATEST_BEFORE = 102, &
+ MPAS_STREAM_EARLIEST_AFTER = 103
+
+
+ ! Error codes
+ integer, parameter :: MPAS_STREAM_NOERR = 0, &
+ MPAS_STREAM_NOT_INITIALIZED = -1, &
+ MPAS_IO_ERR = -2
+
+ integer, parameter :: FIELD_0D_INT = 1, &
+ FIELD_1D_INT = 2, &
+ FIELD_2D_INT = 3, &
+ FIELD_3D_INT = 4, &
+ FIELD_0D_REAL = 5, &
+ FIELD_1D_REAL = 6, &
+ FIELD_2D_REAL = 7, &
+ FIELD_3D_REAL = 8, &
+ FIELD_0D_CHAR = 9, &
+ FIELD_1D_CHAR = 10
+
+ private mergeArrays
+
+
+contains
+
+
+ subroutine MPAS_createStream(stream, fileName, ioFormat, ioDirection, framesPerFile, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(out) :: stream
+ character (len=*), intent(in) :: fileName
+ integer, intent(in) :: ioFormat
+ integer, intent(in) :: ioDirection
+ integer, intent(in) :: framesPerFile
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ stream % fileHandle = MPAS_io_open(fileName, ioDirection, ioFormat, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ stream % ioDirection = ioDirection
+ stream % ioFormat = ioFormat
+ stream % framesPerFile = framesPerFile
+
+ stream % isInitialized = .true.
+
+ end subroutine MPAS_createStream
+
+
+ integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: seekTime
+ integer, intent(in) :: seekPosition
+ character (len=*), intent(out) :: actualTime
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: timeDim
+ character (len=64), dimension(:), pointer :: xtimes
+ character (len=32) :: strTemp
+ type (MPAS_Time_type) :: sliceTime, startTime
+ type (MPAS_TimeInterval_type) :: timeDiff, minTimeDiff
+
+! write(0,*) 'Called MPAS_seekStream'
+
+ !
+ ! Initialize output arguments
+ !
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+ MPAS_seekStream = 0
+
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ call MPAS_io_inq_dim(stream % fileHandle, 'Time', timeDim, io_err)
+ if (timeDim <= 0 .or. io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+!write(0,*) 'Found ', timeDim, ' times in file'
+
+ call MPAS_io_inq_var(stream % fileHandle, 'xtime', ierr=io_err)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+!write(0,*) 'Found xtime variable'
+
+ allocate(xtimes(timeDim))
+
+ do i=1,timeDim
+ call MPAS_io_set_frame(stream % fileHandle, i, io_err)
+ call MPAS_io_get_var(stream % fileHandle, 'xtime', xtimes(i), io_err)
+!write(0,*) '... just read in xtime='//xtimes(i)
+ end do
+
+ if (len(seekTime) > 32) then
+ write(strTemp, '(a)') seekTime(1:32)
+ else
+ write(strTemp, '(a)') trim(seekTime)
+ end if
+ call mpas_set_timeInterval(interval=minTimeDiff, DD=10000)
+ call mpas_set_time(curr_time=startTime, dateTimeString=strTemp)
+
+ do i=1,timeDim
+ write(strTemp, '(a)') trim(xtimes(i)(1:32))
+!write(0,*) '... converted strTemp='//strTemp
+ call mpas_set_time(curr_time=sliceTime, dateTimeString=strTemp)
+ if (seekPosition == MPAS_STREAM_EXACT_TIME) then
+ if (sliceTime == startTime) then
+ minTimeDiff = timeDiff
+ MPAS_seekStream = i
+ end if
+ else if (seekPosition == MPAS_STREAM_NEAREST) then
+ timeDiff = abs(sliceTime - startTime)
+ if (timeDiff < minTimeDiff) then
+ minTimeDiff = timeDiff
+ MPAS_seekStream = i
+ end if
+ else if (seekPosition == MPAS_STREAM_LATEST_BEFORE) then
+ if (sliceTime <= startTime) then
+ timeDiff = abs(sliceTime - startTime)
+ if (timeDiff < minTimeDiff) then
+ minTimeDiff = timeDiff
+ MPAS_seekStream = i
+ end if
+ end if
+ else if (seekPosition == MPAS_STREAM_EARLIEST_AFTER) then
+ if (sliceTime >= startTime) then
+ timeDiff = abs(sliceTime - startTime)
+ if (timeDiff < minTimeDiff) then
+ minTimeDiff = timeDiff
+ MPAS_seekStream = i
+ end if
+ end if
+ else
+ write(0,*) 'Error in MPAS_seekStream: unrecognized seekPosition'
+ deallocate(xtimes)
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+ end do
+
+ if (MPAS_seekStream == 0) then
+ deallocate(xtimes)
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ write(actualTime, '(a)') trim(xtimes(MPAS_seekStream)(1:32))
+
+ deallocate(xtimes)
+
+ end function MPAS_seekStream
+
+
+ subroutine MPAS_streamAddField_0dInteger(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field0DInteger), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field0dInteger), pointer :: field_ptr
+ character (len=64), dimension(:), pointer :: dimNames
+ integer, dimension(:), pointer :: indices
+ integer, dimension(:), pointer :: dimSizes
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = 0
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+ idim = ndims
+ allocate(indices(0))
+ allocate(dimSizes(0))
+ allocate(dimNames(0))
+ isDecomposed = .false.
+ globalDimSize = 0
+ totalDimSize = 0
+
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_INT, dimNames, dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+
+ deallocate(indices)
+ deallocate(dimSizes)
+ deallocate(dimNames)
+ if (io_err /= MPAS_STREAM_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_0D_INT
+ new_field_list_node % int0dField => field
+
+!write(0,*) '... done adding field'
+
+ end subroutine MPAS_streamAddField_0dInteger
+
+
+ subroutine MPAS_streamAddField_1dInteger(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field1DInteger), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field1dInteger), pointer :: field_ptr
+ character (len=64), dimension(5) :: dimNames
+ character (len=64), dimension(:), pointer :: dimNamesInq
+ character (len=64), dimension(0) :: dimNames0
+ integer, dimension(0) :: dimSizes0
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_INT, dimNames0, &
+ dimSizes0, field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_INT, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_1D_INT
+ new_field_list_node % int1dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+
+ end subroutine MPAS_streamAddField_1dInteger
+
+
+ subroutine MPAS_streamAddField_2dInteger(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field2DInteger), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field2dInteger), pointer :: field_ptr
+ character (len=64), dimension(5) :: dimNames
+ character (len=64), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_INT, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_INT, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_2D_INT
+ new_field_list_node % int2dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+
+ end subroutine MPAS_streamAddField_2dInteger
+
+
+ subroutine MPAS_streamAddField_3dInteger(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field3DInteger), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field3dInteger), pointer :: field_ptr
+ character (len=64), dimension(5) :: dimNames
+ character (len=64), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+ any_success = .false.
+ if (field % isSuperArray) then
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_INT, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_INT, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_3D_INT
+ new_field_list_node % int3dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+
+ end subroutine MPAS_streamAddField_3dInteger
+
+
+ subroutine MPAS_streamAddField_0dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field0DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field0dReal), pointer :: field_ptr
+ character (len=64), dimension(:), pointer :: dimNames
+ integer, dimension(:), pointer :: indices
+ integer, dimension(:), pointer :: dimSizes
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = 0
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+ idim = ndims
+ allocate(indices(0))
+ allocate(dimSizes(0))
+ allocate(dimNames(0))
+ isDecomposed = .false.
+ globalDimSize = 0
+ totalDimSize = 0
+
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, dimNames, dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+
+ deallocate(indices)
+ deallocate(dimSizes)
+ deallocate(dimNames)
+ if (io_err /= MPAS_STREAM_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_0D_REAL
+ new_field_list_node % real0dField => field
+
+!write(0,*) '... done adding field'
+
+ end subroutine MPAS_streamAddField_0dReal
+
+
+ subroutine MPAS_streamAddField_1dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field1DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field1dReal), pointer :: field_ptr
+ character (len=64), dimension(5) :: dimNames
+ character (len=64), dimension(:), pointer :: dimNamesInq
+ character (len=64), dimension(0) :: dimNames0
+ integer, dimension(0) :: dimSizes0
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, dimNames0, &
+ dimSizes0, field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_1D_REAL
+ new_field_list_node % real1dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+
+ end subroutine MPAS_streamAddField_1dReal
+
+
+ subroutine MPAS_streamAddField_2dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field2DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field2dReal), pointer :: field_ptr
+ character (len=64), dimension(5) :: dimNames
+ character (len=64), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_2D_REAL
+ new_field_list_node % real2dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+
+ end subroutine MPAS_streamAddField_2dReal
+
+
+ subroutine MPAS_streamAddField_3dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field3DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field3dReal), pointer :: field_ptr
+ character (len=64), dimension(5) :: dimNames
+ character (len=64), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+!write(0,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^ we are adding a super-array'
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_3D_REAL
+ new_field_list_node % real3dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+!write(0,*) 'DEBUGGING : Finished adding 3d real field '//trim(field % fieldName)
+
+ end subroutine MPAS_streamAddField_3dReal
+
+
+ subroutine MPAS_streamAddField_0dChar(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field0DChar), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field0dChar), pointer :: field_ptr
+ character (len=64), dimension(5) :: dimNames
+ character (len=64), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: dimSizes
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = 1
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+ idim = ndims
+ allocate(indices(0))
+ allocate(dimSizes(1))
+ dimSizes(1) = 64
+ dimNames(1) = 'StrLen'
+ isDecomposed = .false.
+ globalDimSize = 64
+ totalDimSize = 64
+
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_CHAR, dimNames(1:1), &
+ dimSizes, field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ end do
+ else
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_CHAR, dimNames(1:1), dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ end if
+
+ deallocate(indices)
+ deallocate(dimSizes)
+ if (io_err /= MPAS_STREAM_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_0D_CHAR
+ new_field_list_node % char0dField => field
+
+!write(0,*) '... done adding field'
+
+ end subroutine MPAS_streamAddField_0dChar
+
+
+ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, dimSizes, hasTimeDimension, isDecomposed, &
+ totalDimSize, globalDimSize, indices, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: fieldName
+ integer, intent(in) :: fieldType
+ character (len=64), dimension(:), intent(in) :: dimNames
+ integer, dimension(:), intent(in) :: dimSizes
+ logical, intent(in) :: hasTimeDimension
+ logical, intent(in) :: isDecomposed
+ integer, intent(in) :: totalDimSize
+ integer, intent(in) :: globalDimSize
+ integer, dimension(:), intent(in) :: indices
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: ndims
+ integer :: dimTemp
+ character (len=64), dimension(5) :: dimNamesLocal
+ character (len=64), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: dimSizesInq
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ ndims = size(dimNames)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ allocate(new_field_list_node)
+ nullify(new_field_list_node % next)
+
+ if (stream % ioDirection == MPAS_IO_WRITE) then
+!write(0,*) '... defining field'
+
+ !
+ ! Define inner dimensions
+ !
+ do idim = 1, ndims-1
+!write(0,*) '... defining dimension ', trim(dimNames(idim)), dimSizes(idim)
+ write(dimNamesLocal(idim),'(a)') dimNames(idim)
+ call MPAS_io_def_dim(stream % fileHandle, trim(dimNames(idim)), dimSizes(idim), io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ deallocate(new_field_list_node)
+ return
+ end if
+ end do
+
+ !
+ ! Define outer-most dimension
+ !
+ idim = ndims
+ if (idim > 0) write(dimNamesLocal(idim),'(a)') dimNames(idim)
+
+ if (isDecomposed) then
+ new_field_list_node % totalDimSize = totalDimSize
+ else
+ new_field_list_node % totalDimSize = globalDimSize
+ end if
+
+ new_field_list_node % isDecomposed = isDecomposed
+
+ if (ndims > 0) then
+!write(0,*) '... defining dimension ', trim(dimNames(idim)), globalDimSize
+ call MPAS_io_def_dim(stream % fileHandle, trim(dimNames(idim)), globalDimSize, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ deallocate(new_field_list_node)
+ return
+ end if
+ end if
+
+ !
+ ! Define time dimension if necessary
+ !
+ if (hasTimeDimension) then
+!write(0,*) '... defining Time dimension '
+ call MPAS_io_def_dim(stream % fileHandle, 'Time', MPAS_IO_UNLIMITED_DIM, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ deallocate(new_field_list_node)
+ return
+ end if
+ ndims = ndims + 1
+ write(dimNamesLocal(ndims),'(a)') 'Time'
+ end if
+
+ !
+ ! Define variable to low-level interface
+ !
+!write(0,*) '... defining var to low-level interface with ndims ', ndims
+
+ call MPAS_io_def_var(stream % fileHandle, trim(fieldName), fieldType, dimNamesLocal(1:ndims), io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ deallocate(new_field_list_node)
+ return
+ end if
+
+ else if (stream % ioDirection == MPAS_IO_READ) then
+!write(0,*) '... inquiring about'
+
+ call MPAS_io_inq_var(stream % fileHandle, trim(fieldName), dimnames=dimNamesInq, dimsizes=dimSizesInq, ierr=io_err)
+ ! If the field does not exist in the input file, we should handle this situation gracefully at higher levels
+ ! without printing disconcerting error messages
+ !call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ deallocate(new_field_list_node)
+ return
+ end if
+
+! Here, we should probably do a check to make sure the file agrees with what MPAS expects for the field
+ do i=1,ndims
+!write(0,*) 'Comparing '//trim(dimNames(i))//' '//trim(dimNamesInq(i))
+ if (trim(dimNames(i)) /= trim(dimNamesInq(i))) then
+!write(0,*) 'Mismatched dimension name in field'
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ deallocate(new_field_list_node)
+ deallocate(dimNamesInq)
+ deallocate(dimSizesInq)
+ return
+ end if
+ if (i < ndims) then
+ dimTemp = dimSizes(i)
+ else
+ if (trim(dimNamesInq(i)) == 'nCells' .or. &
+ trim(dimNamesInq(i)) == 'nEdges' .or. &
+ trim(dimNamesInq(i)) == 'nVertices' &
+ ) then
+ dimTemp = globalDimSize
+ else
+ dimTemp = dimSizes(i)
+ end if
+ end if
+!write(0,*) 'Comparing ', dimTemp, ' ', dimSizesInq(i)
+ if (dimTemp /= dimSizesInq(i)) then
+!write(0,*) 'Mismatched dimension size in field'
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ deallocate(new_field_list_node)
+ deallocate(dimNamesInq)
+ deallocate(dimSizesInq)
+ return
+ end if
+ end do
+
+ ! Set outer dimension sizes depending on whether the field is decomposed
+ if (isDecomposed) then
+ new_field_list_node % totalDimSize = totalDimSize
+ else
+ new_field_list_node % totalDimSize = globalDimSize
+ end if
+
+ new_field_list_node % isDecomposed = isDecomposed
+
+ deallocate(dimNamesInq)
+ deallocate(dimSizesInq)
+
+ end if
+
+
+ !
+ ! Set variable indices
+ !
+ if (ndims > 0) then
+ call MPAS_io_set_var_indices(stream % fileHandle, trim(fieldName), indices, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ deallocate(new_field_list_node)
+ return
+ end if
+ end if
+
+
+ !
+ ! Add field pointer to the list
+ !
+ if (.not. associated(stream % fieldList)) then
+!write(0,*) 'Adding field to the head of the list'
+ stream % fieldList => new_field_list_node
+ else
+!write(0,*) 'Adding field to the tail of the list'
+ field_list_cursor => stream % fieldList
+ do while (associated(field_list_cursor % next))
+ field_list_cursor => field_list_cursor % next
+ end do
+ field_list_cursor % next => new_field_list_node
+ end if
+
+ end subroutine MPAS_streamAddField_generic
+
+
+ subroutine MPAS_readStream(stream, frame, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ integer, intent(in) :: frame
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i, j
+ integer :: ncons
+ integer :: ownedSize
+ type (field0dInteger), pointer :: field_0dint_ptr
+ type (field1dInteger), pointer :: field_1dint_ptr
+ type (field2dInteger), pointer :: field_2dint_ptr
+ type (field3dInteger), pointer :: field_3dint_ptr
+ type (field0dReal), pointer :: field_0dreal_ptr
+ type (field1dReal), pointer :: field_1dreal_ptr
+ type (field2dReal), pointer :: field_2dreal_ptr
+ type (field3dReal), pointer :: field_3dreal_ptr
+ type (field0dChar), pointer :: field_0dchar_ptr
+ type (field1dChar), pointer :: field_1dchar_ptr
+ type (field_list_type), pointer :: field_cursor
+ integer :: int0d_temp
+ integer, dimension(:), pointer :: int1d_temp
+ integer, dimension(:,:), pointer :: int2d_temp
+ integer, dimension(:,:,:), pointer :: int3d_temp
+ real (kind=RKIND) :: real0d_temp
+ real (kind=RKIND), dimension(:), pointer :: real1d_temp
+ real (kind=RKIND), dimension(:,:), pointer :: real2d_temp
+ real (kind=RKIND), dimension(:,:,:), pointer :: real3d_temp
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+
+ !
+ ! Set time frame to real
+ !
+ call MPAS_io_set_frame(stream % fileHandle, frame, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+
+ !
+ ! Loop over fields in the stream
+ !
+ field_cursor => stream % fieldList
+ do while (associated(field_cursor))
+ if (field_cursor % field_type == FIELD_0D_INT) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % int0dField % fieldName)
+!write(0,*) 'Reading in field '//trim(field_cursor % int0dField % fieldName)
+!write(0,*) ' > is the field decomposed? ', field_cursor % isDecomposed
+!write(0,*) ' > outer dimension size ', field_cursor % totalDimSize
+
+!write(0,*) 'MGD calling MPAS_io_get_var now...'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % int0dField % fieldName, int0d_temp, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+!write(0,*) 'Distributing and Copying field to other blocks'
+
+ call mpas_dmpar_bcast_int(field_cursor % int0dField % block % domain % dminfo, int0d_temp)
+ field_0dint_ptr => field_cursor % int0dField
+ do while (associated(field_0dint_ptr))
+ field_0dint_ptr % scalar = int0d_temp
+ field_0dint_ptr => field_0dint_ptr % next
+ end do
+
+ else if (field_cursor % field_type == FIELD_1D_INT) then
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % int1dField % fieldName)
+
+ if (field_cursor % int1dField % isSuperArray) then
+ ncons = size(field_cursor % int1dField % constituentNames)
+ else
+ ncons = 1
+ allocate(int1d_temp(field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % int1dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % int1dField % constituentNames(j), int0d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % int1dField % fieldName, int1d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (.not. field_cursor % int1dField % isSuperArray) then
+ deallocate(int1d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_1dint_ptr => field_cursor % int1dField
+ i = 1
+ if (trim(field_1dint_ptr % dimNames(1)) == 'nCells') then
+ ownedSize = field_1dint_ptr % block % mesh % nCellsSolve
+ else if (trim(field_1dint_ptr % dimNames(1)) == 'nEdges') then
+ ownedSize = field_1dint_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_1dint_ptr % dimNames(1)) == 'nVertices') then
+ ownedSize = field_1dint_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_1dint_ptr % dimSizes(1)
+ end if
+ do while (associated(field_1dint_ptr))
+ if (field_cursor % int1dField % isSuperArray) then
+ field_1dint_ptr % array(j) = int0d_temp
+ else
+ field_1dint_ptr % array(1:ownedSize) = int1d_temp(i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_1dint_ptr => field_1dint_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % int1dField % isSuperArray) then
+ call mpas_dmpar_bcast_int(field_cursor % int1dField % block % domain % dminfo, int0d_temp)
+ field_1dint_ptr => field_cursor % int1dField
+ do while (associated(field_1dint_ptr))
+ field_1dint_ptr % array(j) = int0d_temp
+ field_1dint_ptr => field_1dint_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_ints(field_cursor % int1dField % block % domain % dminfo, size(int1d_temp), int1d_temp(:))
+ field_1dint_ptr => field_cursor % int1dField
+ do while (associated(field_1dint_ptr))
+ field_1dint_ptr % array(:) = int1d_temp(:)
+ field_1dint_ptr => field_1dint_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (.not. field_cursor % int1dField % isSuperArray) then
+ deallocate(int1d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_2D_INT) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % int2dField % fieldName)
+ if (field_cursor % int2dField % isSuperArray) then
+ ncons = size(field_cursor % int2dField % constituentNames)
+ allocate(int1d_temp(field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(int2d_temp(field_cursor % int2dField % dimSizes(1), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % int2dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % int2dField % constituentNames(j), int1d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % int2dField % fieldName, int2d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % int2dField % isSuperArray) then
+ deallocate(int1d_temp)
+ else
+ deallocate(int2d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_2dint_ptr => field_cursor % int2dField
+ i = 1
+ if (trim(field_2dint_ptr % dimNames(2)) == 'nCells') then
+ ownedSize = field_2dint_ptr % block % mesh % nCellsSolve
+ else if (trim(field_2dint_ptr % dimNames(2)) == 'nEdges') then
+ ownedSize = field_2dint_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_2dint_ptr % dimNames(2)) == 'nVertices') then
+ ownedSize = field_2dint_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_2dint_ptr % dimSizes(2)
+ end if
+ do while (associated(field_2dint_ptr))
+ if (field_cursor % int2dField % isSuperArray) then
+ field_2dint_ptr % array(j,1:ownedSize) = int1d_temp(i:i+ownedSize-1)
+ else
+ field_2dint_ptr % array(:,1:ownedSize) = int2d_temp(:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_2dint_ptr => field_2dint_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % int2dField % isSuperArray) then
+ call mpas_dmpar_bcast_ints(field_cursor % int2dField % block % domain % dminfo, size(int1d_temp), int1d_temp(:))
+ field_2dint_ptr => field_cursor % int2dField
+ do while (associated(field_2dint_ptr))
+ field_2dint_ptr % array(j,:) = int1d_temp(:)
+ field_2dint_ptr => field_2dint_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_ints(field_cursor % int2dField % block % domain % dminfo, size(int2d_temp), int2d_temp(:,1))
+ field_2dint_ptr => field_cursor % int2dField
+ do while (associated(field_2dint_ptr))
+ field_2dint_ptr % array(:,:) = int2d_temp(:,:)
+ field_2dint_ptr => field_2dint_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % int2dField % isSuperArray) then
+ deallocate(int1d_temp)
+ else
+ deallocate(int2d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_3D_INT) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % int3dField % fieldName)
+ if (field_cursor % int3dField % isSuperArray) then
+ ncons = size(field_cursor % int3dField % constituentNames)
+ allocate(int2d_temp(field_cursor % int3dField % dimSizes(2), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(int3d_temp(field_cursor % int3dField % dimSizes(1), &
+ field_cursor % int3dField % dimSizes(2), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % int3dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % int3dField % constituentNames(j), int2d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % int3dField % fieldName, int3d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % int3dField % isSuperArray) then
+ deallocate(int2d_temp)
+ else
+ deallocate(int3d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_3dint_ptr => field_cursor % int3dField
+ i = 1
+ if (trim(field_3dint_ptr % dimNames(3)) == 'nCells') then
+ ownedSize = field_3dint_ptr % block % mesh % nCellsSolve
+ else if (trim(field_3dint_ptr % dimNames(3)) == 'nEdges') then
+ ownedSize = field_3dint_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_3dint_ptr % dimNames(3)) == 'nVertices') then
+ ownedSize = field_3dint_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_3dint_ptr % dimSizes(3)
+ end if
+ do while (associated(field_3dint_ptr))
+ if (field_cursor % int3dField % isSuperArray) then
+ field_3dint_ptr % array(j,:,1:ownedSize) = int2d_temp(:,i:i+ownedSize-1)
+ else
+ field_3dint_ptr % array(:,:,1:ownedSize) = int3d_temp(:,:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_3dint_ptr => field_3dint_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % int3dField % isSuperArray) then
+ call mpas_dmpar_bcast_ints(field_cursor % int3dField % block % domain % dminfo, size(int2d_temp), int2d_temp(:,1))
+ field_3dint_ptr => field_cursor % int3dField
+ do while (associated(field_3dint_ptr))
+ field_3dint_ptr % array(j,:,:) = int2d_temp(:,:)
+ field_3dint_ptr => field_3dint_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_ints(field_cursor % int3dField % block % domain % dminfo, size(int3d_temp), int3d_temp(:,1,1))
+ field_3dint_ptr => field_cursor % int3dField
+ do while (associated(field_3dint_ptr))
+ field_3dint_ptr % array(:,:,:) = int3d_temp(:,:,:)
+ field_3dint_ptr => field_3dint_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % int3dField % isSuperArray) then
+ deallocate(int2d_temp)
+ else
+ deallocate(int3d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_0D_REAL) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real0dField % fieldName)
+!write(0,*) 'Reading in field '//trim(field_cursor % real0dField % fieldName)
+!write(0,*) ' > is the field decomposed? ', field_cursor % isDecomposed
+!write(0,*) ' > outer dimension size ', field_cursor % totalDimSize
+
+!write(0,*) 'MGD calling MPAS_io_get_var now...'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real0dField % fieldName, real0d_temp, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+!write(0,*) 'Distributing and Copying field to other blocks'
+
+ call mpas_dmpar_bcast_real(field_cursor % real0dField % block % domain % dminfo, real0d_temp)
+ field_0dreal_ptr => field_cursor % real0dField
+ do while (associated(field_0dreal_ptr))
+ field_0dreal_ptr % scalar = real0d_temp
+ field_0dreal_ptr => field_0dreal_ptr % next
+ end do
+
+ else if (field_cursor % field_type == FIELD_1D_REAL) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real1dField % fieldName)
+ if (field_cursor % real1dField % isSuperArray) then
+ ncons = size(field_cursor % real1dField % constituentNames)
+ else
+ ncons = 1
+ allocate(real1d_temp(field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real1dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real1dField % constituentNames(j), real0d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real1dField % fieldName, real1d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (.not. field_cursor % real1dField % isSuperArray) then
+ deallocate(real1d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_1dreal_ptr => field_cursor % real1dField
+ i = 1
+ if (trim(field_1dreal_ptr % dimNames(1)) == 'nCells') then
+ ownedSize = field_1dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_1dreal_ptr % dimNames(1)) == 'nEdges') then
+ ownedSize = field_1dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_1dreal_ptr % dimNames(1)) == 'nVertices') then
+ ownedSize = field_1dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_1dreal_ptr % dimSizes(1)
+ end if
+ do while (associated(field_1dreal_ptr))
+ if (field_cursor % real1dField % isSuperArray) then
+ field_1dreal_ptr % array(j) = real0d_temp
+ else
+ field_1dreal_ptr % array(1:ownedSize) = real1d_temp(i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_1dreal_ptr => field_1dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real1dField % isSuperArray) then
+ call mpas_dmpar_bcast_real(field_cursor % real1dField % block % domain % dminfo, real0d_temp)
+ field_1dreal_ptr => field_cursor % real1dField
+ do while (associated(field_1dreal_ptr))
+ field_1dreal_ptr % array(j) = real0d_temp
+ field_1dreal_ptr => field_1dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real1dField % block % domain % dminfo, size(real1d_temp), real1d_temp(:))
+ field_1dreal_ptr => field_cursor % real1dField
+ do while (associated(field_1dreal_ptr))
+ field_1dreal_ptr % array(:) = real1d_temp(:)
+ field_1dreal_ptr => field_1dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (.not. field_cursor % real1dField % isSuperArray) then
+ deallocate(real1d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_2D_REAL) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real2dField % fieldName)
+ if (field_cursor % real2dField % isSuperArray) then
+ ncons = size(field_cursor % real2dField % constituentNames)
+ allocate(real1d_temp(field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real2d_temp(field_cursor % real2dField % dimSizes(1), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real2dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real2dField % constituentNames(j), real1d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real2dField % fieldName, real2d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % real2dField % isSuperArray) then
+ deallocate(real1d_temp)
+ else
+ deallocate(real2d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_2dreal_ptr => field_cursor % real2dField
+ i = 1
+ if (trim(field_2dreal_ptr % dimNames(2)) == 'nCells') then
+ ownedSize = field_2dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_2dreal_ptr % dimNames(2)) == 'nEdges') then
+ ownedSize = field_2dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_2dreal_ptr % dimNames(2)) == 'nVertices') then
+ ownedSize = field_2dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_2dreal_ptr % dimSizes(2)
+ end if
+ do while (associated(field_2dreal_ptr))
+ if (field_cursor % real2dField % isSuperArray) then
+ field_2dreal_ptr % array(j,1:ownedSize) = real1d_temp(i:i+ownedSize-1)
+ else
+ field_2dreal_ptr % array(:,1:ownedSize) = real2d_temp(:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_2dreal_ptr => field_2dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real2dField % isSuperArray) then
+ call mpas_dmpar_bcast_reals(field_cursor % real2dField % block % domain % dminfo, size(real1d_temp), real1d_temp(:))
+ field_2dreal_ptr => field_cursor % real2dField
+ do while (associated(field_2dreal_ptr))
+ field_2dreal_ptr % array(j,:) = real1d_temp(:)
+ field_2dreal_ptr => field_2dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real2dField % block % domain % dminfo, size(real2d_temp), real2d_temp(:,1))
+ field_2dreal_ptr => field_cursor % real2dField
+ do while (associated(field_2dreal_ptr))
+ field_2dreal_ptr % array(:,:) = real2d_temp(:,:)
+ field_2dreal_ptr => field_2dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % real2dField % isSuperArray) then
+ deallocate(real1d_temp)
+ else
+ deallocate(real2d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_3D_REAL) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real3dField % fieldName)
+!write(0,*) 'DEBUGGING : reading a 3d real array'
+ if (field_cursor % real3dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : reading a 3d real super-array'
+ ncons = size(field_cursor % real3dField % constituentNames)
+ allocate(real2d_temp(field_cursor % real3dField % dimSizes(2), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real3d_temp(field_cursor % real3dField % dimSizes(1), &
+ field_cursor % real3dField % dimSizes(2), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real3dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+!write(0,*) 'DEBUGGING : calling get_var for a constitutent'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real3dField % constituentNames(j), real2d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real3dField % fieldName, real3d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % real3dField % isSuperArray) then
+ deallocate(real2d_temp)
+ else
+ deallocate(real3d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_3dreal_ptr => field_cursor % real3dField
+ i = 1
+ if (trim(field_3dreal_ptr % dimNames(3)) == 'nCells') then
+ ownedSize = field_3dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_3dreal_ptr % dimNames(3)) == 'nEdges') then
+ ownedSize = field_3dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_3dreal_ptr % dimNames(3)) == 'nVertices') then
+ ownedSize = field_3dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_3dreal_ptr % dimSizes(3)
+ end if
+ do while (associated(field_3dreal_ptr))
+ if (field_cursor % real3dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : copying the temporary array'
+ field_3dreal_ptr % array(j,:,1:ownedSize) = real2d_temp(:,i:i+ownedSize-1)
+ else
+ field_3dreal_ptr % array(:,:,1:ownedSize) = real3d_temp(:,:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_3dreal_ptr => field_3dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real3dField % isSuperArray) then
+ call mpas_dmpar_bcast_reals(field_cursor % real3dField % block % domain % dminfo, size(real2d_temp), real2d_temp(:,1))
+ field_3dreal_ptr => field_cursor % real3dField
+ do while (associated(field_3dreal_ptr))
+ field_3dreal_ptr % array(j,:,:) = real2d_temp(:,:)
+ field_3dreal_ptr => field_3dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real3dField % block % domain % dminfo, size(real3d_temp), real3d_temp(:,1,1))
+ field_3dreal_ptr => field_cursor % real3dField
+ do while (associated(field_3dreal_ptr))
+ field_3dreal_ptr % array(:,:,:) = real3d_temp(:,:,:)
+ field_3dreal_ptr => field_3dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % real3dField % isSuperArray) then
+ deallocate(real2d_temp)
+ else
+ deallocate(real3d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_0D_CHAR) then
+
+!write(0,*) 'Reading in field '//trim(field_cursor % char0dField % fieldName)
+!write(0,*) ' > is the field decomposed? ', field_cursor % isDecomposed
+!write(0,*) ' > outer dimension size ', field_cursor % totalDimSize
+
+!write(0,*) 'MGD calling MPAS_io_get_var now...'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % char0dField % fieldName, field_cursor % char0dField % scalar, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+!write(0,*) 'Distributing and Copying field to other blocks'
+
+ call mpas_dmpar_bcast_char(field_cursor % char0dField % block % domain % dminfo, field_cursor % char0dField % scalar)
+ field_0dchar_ptr => field_cursor % char0dField
+ do while (associated(field_0dchar_ptr))
+ field_0dchar_ptr % scalar = field_cursor % char0dField % scalar
+ field_0dchar_ptr => field_0dchar_ptr % next
+ end do
+
+ else if (field_cursor % field_type == FIELD_1D_CHAR) then
+ end if
+ field_cursor => field_cursor % next
+ end do
+!write(0,*) 'Finished fieldlist loop...'
+
+ end subroutine MPAS_readStream
+
+
+ subroutine MPAS_writeStream(stream, frame, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ integer, intent(in) :: frame
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i, j
+ integer :: ncons
+ integer :: ownedSize
+ type (field0dInteger), pointer :: field_0dint_ptr
+ type (field1dInteger), pointer :: field_1dint_ptr
+ type (field2dInteger), pointer :: field_2dint_ptr
+ type (field3dInteger), pointer :: field_3dint_ptr
+ type (field0dReal), pointer :: field_0dreal_ptr
+ type (field1dReal), pointer :: field_1dreal_ptr
+ type (field2dReal), pointer :: field_2dreal_ptr
+ type (field3dReal), pointer :: field_3dreal_ptr
+ type (field0dChar), pointer :: field_0dchar_ptr
+ type (field1dChar), pointer :: field_1dchar_ptr
+ type (field_list_type), pointer :: field_cursor
+ integer :: int0d_temp
+ integer, dimension(:), pointer :: int1d_temp
+ integer, dimension(:,:), pointer :: int2d_temp
+ integer, dimension(:,:,:), pointer :: int3d_temp
+ real (kind=RKIND) :: real0d_temp
+ real (kind=RKIND), dimension(:), pointer :: real1d_temp
+ real (kind=RKIND), dimension(:,:), pointer :: real2d_temp
+ real (kind=RKIND), dimension(:,:,:), pointer :: real3d_temp
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ !
+ ! Set time frame to write
+ !
+ call MPAS_io_set_frame(stream % fileHandle, frame, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ !
+ ! Loop over fields in the stream
+ !
+ field_cursor => stream % fieldList
+ do while (associated(field_cursor))
+
+ if (field_cursor % field_type == FIELD_0D_INT) then
+
+!write(0,*) 'Writing out field '//trim(field_cursor % int0dField % fieldName)
+!write(0,*) ' > is the field decomposed? ', field_cursor % isDecomposed
+!write(0,*) ' > outer dimension size ', field_cursor % totalDimSize
+
+!write(0,*) 'Copying field from first block'
+ int0d_temp = field_cursor % int0dField % scalar
+
+!write(0,*) 'MGD calling MPAS_io_put_var now...'
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % int0dField % fieldName, int0d_temp, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ else if (field_cursor % field_type == FIELD_1D_INT) then
+
+ if (field_cursor % int1dField % isSuperArray) then
+ ncons = size(field_cursor % int1dField % constituentNames)
+ else
+ ncons = 1
+ allocate(int1d_temp(field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % isDecomposed) then
+ ! Gather field from across multiple blocks
+ field_1dint_ptr => field_cursor % int1dField
+ i = 1
+ do while (associated(field_1dint_ptr))
+ if (trim(field_1dint_ptr % dimNames(1)) == 'nCells') then
+ ownedSize = field_1dint_ptr % block % mesh % nCellsSolve
+ else if (trim(field_1dint_ptr % dimNames(1)) == 'nEdges') then
+ ownedSize = field_1dint_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_1dint_ptr % dimNames(1)) == 'nVertices') then
+ ownedSize = field_1dint_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_1dint_ptr % dimSizes(1)
+ end if
+
+ if (field_cursor % int1dField % isSuperArray) then
+! I suspect we will never hit this code, as it doesn't make sense, really
+ int0d_temp = field_1dint_ptr % array(j)
+ else
+ int1d_temp(i:i+ownedSize-1) = field_1dint_ptr % array(1:ownedSize)
+ end if
+ i = i + ownedSize
+ field_1dint_ptr => field_1dint_ptr % next
+ end do
+ else
+ if (field_cursor % int1dField % isSuperArray) then
+ int0d_temp = field_cursor % int1dField % array(j)
+ else
+ int1d_temp(:) = field_cursor % int1dField % array(:)
+ end if
+ end if
+
+ if (field_cursor % int1dField % isSuperArray) then
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % int1dField % constituentNames(j), int0d_temp, io_err)
+ else
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % int1dField % fieldName, int1d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+ end do
+
+ if (.not. field_cursor % int1dField % isSuperArray) then
+ deallocate(int1d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_2D_INT) then
+
+ if (field_cursor % int2dField % isSuperArray) then
+ ncons = size(field_cursor % int2dField % constituentNames)
+ allocate(int1d_temp(field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(int2d_temp(field_cursor % int2dField % dimSizes(1), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % isDecomposed) then
+ ! Gather field from across multiple blocks
+ field_2dint_ptr => field_cursor % int2dField
+ i = 1
+ do while (associated(field_2dint_ptr))
+ if (trim(field_2dint_ptr % dimNames(2)) == 'nCells') then
+ ownedSize = field_2dint_ptr % block % mesh % nCellsSolve
+ else if (trim(field_2dint_ptr % dimNames(2)) == 'nEdges') then
+ ownedSize = field_2dint_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_2dint_ptr % dimNames(2)) == 'nVertices') then
+ ownedSize = field_2dint_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_2dint_ptr % dimSizes(2)
+ end if
+
+ if (field_cursor % int2dField % isSuperArray) then
+ int1d_temp(i:i+ownedSize-1) = field_2dint_ptr % array(j,1:ownedSize)
+ else
+ int2d_temp(:,i:i+ownedSize-1) = field_2dint_ptr % array(:,1:ownedSize)
+ end if
+ i = i + ownedSize
+ field_2dint_ptr => field_2dint_ptr % next
+ end do
+ else
+ if (field_cursor % int2dField % isSuperArray) then
+ int1d_temp(:) = field_cursor % int2dField % array(j,:)
+ else
+ int2d_temp(:,:) = field_cursor % int2dField % array(:,:)
+ end if
+ end if
+
+ if (field_cursor % int2dField % isSuperArray) then
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % int2dField % constituentNames(j), int1d_temp, io_err)
+ else
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % int2dField % fieldName, int2d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+ end do
+
+ if (field_cursor % int2dField % isSuperArray) then
+ deallocate(int1d_temp)
+ else
+ deallocate(int2d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_3D_INT) then
+
+ if (field_cursor % int3dField % isSuperArray) then
+ ncons = size(field_cursor % int3dField % constituentNames)
+ allocate(int2d_temp(field_cursor % int3dField % dimSizes(2), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(int3d_temp(field_cursor % int3dField % dimSizes(1), &
+ field_cursor % int3dField % dimSizes(2), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % isDecomposed) then
+ ! Gather field from across multiple blocks
+ field_3dint_ptr => field_cursor % int3dField
+ i = 1
+ do while (associated(field_3dint_ptr))
+ if (trim(field_3dint_ptr % dimNames(3)) == 'nCells') then
+ ownedSize = field_3dint_ptr % block % mesh % nCellsSolve
+ else if (trim(field_3dint_ptr % dimNames(3)) == 'nEdges') then
+ ownedSize = field_3dint_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_3dint_ptr % dimNames(3)) == 'nVertices') then
+ ownedSize = field_3dint_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_3dint_ptr % dimSizes(3)
+ end if
+
+ if (field_cursor % int3dField % isSuperArray) then
+ int2d_temp(:,i:i+ownedSize-1) = field_3dint_ptr % array(j,:,1:ownedSize)
+ else
+ int3d_temp(:,:,i:i+ownedSize-1) = field_3dint_ptr % array(:,:,1:ownedSize)
+ end if
+ i = i + ownedSize
+ field_3dint_ptr => field_3dint_ptr % next
+ end do
+ else
+ if (field_cursor % int3dField % isSuperArray) then
+ int2d_temp(:,:) = field_cursor % int3dField % array(j,:,:)
+ else
+ int3d_temp(:,:,:) = field_cursor % int3dField % array(:,:,:)
+ end if
+ end if
+
+ if (field_cursor % int3dField % isSuperArray) then
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % int3dField % constituentNames(j), int2d_temp, io_err)
+ else
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % int3dField % fieldName, int3d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+ end do
+
+ if (field_cursor % int3dField % isSuperArray) then
+ deallocate(int2d_temp)
+ else
+ deallocate(int3d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_0D_REAL) then
+
+!write(0,*) 'Writing out field '//trim(field_cursor % real0dField % fieldName)
+!write(0,*) ' > is the field decomposed? ', field_cursor % isDecomposed
+!write(0,*) ' > outer dimension size ', field_cursor % totalDimSize
+
+!write(0,*) 'Copying field from first block'
+ real0d_temp = field_cursor % real0dField % scalar
+
+!write(0,*) 'MGD calling MPAS_io_put_var now...'
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % real0dField % fieldName, real0d_temp, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ else if (field_cursor % field_type == FIELD_1D_REAL) then
+
+ if (field_cursor % real1dField % isSuperArray) then
+ ncons = size(field_cursor % real1dField % constituentNames)
+ else
+ ncons = 1
+ allocate(real1d_temp(field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % isDecomposed) then
+ ! Gather field from across multiple blocks
+ field_1dreal_ptr => field_cursor % real1dField
+ i = 1
+ do while (associated(field_1dreal_ptr))
+ if (trim(field_1dreal_ptr % dimNames(1)) == 'nCells') then
+ ownedSize = field_1dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_1dreal_ptr % dimNames(1)) == 'nEdges') then
+ ownedSize = field_1dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_1dreal_ptr % dimNames(1)) == 'nVertices') then
+ ownedSize = field_1dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_1dreal_ptr % dimSizes(1)
+ end if
+
+ if (field_cursor % real1dField % isSuperArray) then
+! I suspect we will never hit this code, as it doesn't make sense, really
+ real0d_temp = field_1dreal_ptr % array(j)
+ else
+ real1d_temp(i:i+ownedSize-1) = field_1dreal_ptr % array(1:ownedSize)
+ end if
+ i = i + ownedSize
+ field_1dreal_ptr => field_1dreal_ptr % next
+ end do
+ else
+ if (field_cursor % real1dField % isSuperArray) then
+ real0d_temp = field_cursor % real1dField % array(j)
+ else
+ real1d_temp(:) = field_cursor % real1dField % array(:)
+ end if
+ end if
+
+ if (field_cursor % real1dField % isSuperArray) then
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % real1dField % constituentNames(j), real0d_temp, io_err)
+ else
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % real1dField % fieldName, real1d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+ end do
+
+ if (.not. field_cursor % real1dField % isSuperArray) then
+ deallocate(real1d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_2D_REAL) then
+
+ if (field_cursor % real2dField % isSuperArray) then
+ ncons = size(field_cursor % real2dField % constituentNames)
+ allocate(real1d_temp(field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real2d_temp(field_cursor % real2dField % dimSizes(1), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % isDecomposed) then
+ ! Gather field from across multiple blocks
+ field_2dreal_ptr => field_cursor % real2dField
+ i = 1
+ do while (associated(field_2dreal_ptr))
+ if (trim(field_2dreal_ptr % dimNames(2)) == 'nCells') then
+ ownedSize = field_2dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_2dreal_ptr % dimNames(2)) == 'nEdges') then
+ ownedSize = field_2dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_2dreal_ptr % dimNames(2)) == 'nVertices') then
+ ownedSize = field_2dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_2dreal_ptr % dimSizes(2)
+ end if
+
+ if (field_cursor % real2dField % isSuperArray) then
+ real1d_temp(i:i+ownedSize-1) = field_2dreal_ptr % array(j,1:ownedSize)
+ else
+ real2d_temp(:,i:i+ownedSize-1) = field_2dreal_ptr % array(:,1:ownedSize)
+ end if
+ i = i + ownedSize
+ field_2dreal_ptr => field_2dreal_ptr % next
+ end do
+ else
+ if (field_cursor % real2dField % isSuperArray) then
+ real1d_temp(:) = field_cursor % real2dField % array(j,:)
+ else
+ real2d_temp(:,:) = field_cursor % real2dField % array(:,:)
+ end if
+ end if
+
+ if (field_cursor % real2dField % isSuperArray) then
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % real2dField % constituentNames(j), real1d_temp, io_err)
+ else
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % real2dField % fieldName, real2d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+ end do
+
+ if (field_cursor % real2dField % isSuperArray) then
+ deallocate(real1d_temp)
+ else
+ deallocate(real2d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_3D_REAL) then
+
+ if (field_cursor % real3dField % isSuperArray) then
+ ncons = size(field_cursor % real3dField % constituentNames)
+ allocate(real2d_temp(field_cursor % real3dField % dimSizes(2), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real3d_temp(field_cursor % real3dField % dimSizes(1), &
+ field_cursor % real3dField % dimSizes(2), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % isDecomposed) then
+ ! Gather field from across multiple blocks
+ field_3dreal_ptr => field_cursor % real3dField
+ i = 1
+ do while (associated(field_3dreal_ptr))
+ if (trim(field_3dreal_ptr % dimNames(3)) == 'nCells') then
+ ownedSize = field_3dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_3dreal_ptr % dimNames(3)) == 'nEdges') then
+ ownedSize = field_3dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_3dreal_ptr % dimNames(3)) == 'nVertices') then
+ ownedSize = field_3dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_3dreal_ptr % dimSizes(3)
+ end if
+
+ if (field_cursor % real3dField % isSuperArray) then
+ real2d_temp(:,i:i+ownedSize-1) = field_3dreal_ptr % array(j,:,1:ownedSize)
+ else
+ real3d_temp(:,:,i:i+ownedSize-1) = field_3dreal_ptr % array(:,:,1:ownedSize)
+ end if
+ i = i + ownedSize
+ field_3dreal_ptr => field_3dreal_ptr % next
+ end do
+ else
+ if (field_cursor % real3dField % isSuperArray) then
+ real2d_temp(:,:) = field_cursor % real3dField % array(j,:,:)
+ else
+ real3d_temp(:,:,:) = field_cursor % real3dField % array(:,:,:)
+ end if
+ end if
+
+ if (field_cursor % real3dField % isSuperArray) then
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % real3dField % constituentNames(j), real2d_temp, io_err)
+ else
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % real3dField % fieldName, real3d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+ end do
+
+ if (field_cursor % real3dField % isSuperArray) then
+ deallocate(real2d_temp)
+ else
+ deallocate(real3d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_0D_CHAR) then
+
+!write(0,*) 'Writing out field '//trim(field_cursor % char0dField % fieldName)
+!write(0,*) ' > is the field decomposed? ', field_cursor % isDecomposed
+!write(0,*) ' > outer dimension size ', field_cursor % totalDimSize
+
+!write(0,*) 'Copying field from first block'
+!write(0,*) 'MGD calling MPAS_io_put_var now...'
+ call MPAS_io_put_var(stream % fileHandle, field_cursor % char0dField % fieldName, field_cursor % char0dField % scalar, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ else if (field_cursor % field_type == FIELD_1D_CHAR) then
+ end if
+ field_cursor => field_cursor % next
+ end do
+
+
+ !
+ ! Sync all fields with disk
+ !
+ call MPAS_io_sync(stream % fileHandle)
+
+ end subroutine MPAS_writeStream
+
+
+ subroutine MPAS_readStreamAtt_0dInteger(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ integer, intent(out) :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_get_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_readStreamAtt_0dInteger
+
+
+ subroutine MPAS_readStreamAtt_1dInteger(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ integer, dimension(:), pointer :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_get_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_readStreamAtt_1dInteger
+
+
+ subroutine MPAS_readStreamAtt_0dReal(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), intent(out) :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_get_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_readStreamAtt_0dReal
+
+
+ subroutine MPAS_readStreamAtt_1dReal(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), dimension(:), pointer :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_get_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_readStreamAtt_1dReal
+
+
+ subroutine MPAS_readStreamAtt_text(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ character (len=*), intent(out) :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_get_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_readStreamAtt_text
+
+
+ subroutine MPAS_writeStreamAtt_0dInteger(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ integer, intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_put_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_writeStreamAtt_0dInteger
+
+
+ subroutine MPAS_writeStreamAtt_1dInteger(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ integer, dimension(:), intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_put_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_writeStreamAtt_1dInteger
+
+
+ subroutine MPAS_writeStreamAtt_0dReal(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_put_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_writeStreamAtt_0dReal
+
+
+ subroutine MPAS_writeStreamAtt_1dReal(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ real (kind=RKIND), dimension(:), intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_put_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_writeStreamAtt_1dReal
+
+
+ subroutine MPAS_writeStreamAtt_text(stream, attName, attValue, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ character (len=*), intent(in) :: attName
+ character (len=*), intent(in) :: attValue
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_put_att(stream % fileHandle, attName, attValue, ierr=io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+ end subroutine MPAS_writeStreamAtt_text
+
+
+ subroutine MPAS_closeStream(stream, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ type (field_list_type), pointer :: field_cursor
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+ call MPAS_io_close(stream % fileHandle, io_err)
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR
+
+!write(0,*) 'Deallocating global attribute list'
+ call mpas_deallocate_attlist(stream % attList)
+
+!write(0,*) 'Deallocating field list'
+ field_cursor => stream % fieldList
+ do while (associated(field_cursor))
+ if (associated(field_cursor % isAvailable)) then
+ deallocate(field_cursor % isAvailable)
+!write(0,*) 'Deallocating isAvailable array'
+ end if
+ stream % fieldList => stream % fieldList % next
+ deallocate(field_cursor)
+ field_cursor => stream % fieldList
+ end do
+
+ stream % isInitialized = .false.
+
+ end subroutine MPAS_closeStream
+
+
+ subroutine mergeArrays(array1, array2)
+
+ implicit none
+
+ integer, dimension(:), pointer :: array1
+ integer, dimension(:), intent(in) :: array2
+
+ integer :: n1, n2
+ integer, dimension(:), pointer :: newArray
+
+ n1 = size(array1)
+ n2 = size(array2)
+
+ allocate(newArray(n1+n2))
+
+ newArray(1:n1) = array1(:)
+ newArray(n1+1:n1+n2) = array2(:)
+
+ deallocate(array1)
+ array1 => newArray
+
+ end subroutine mergeArrays
+
+
+ subroutine put_get_field_atts(handle, ioDirection, fieldname, attList)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ integer, intent(in) :: ioDirection
+ character (len=*), intent(in) :: fieldname
+ type (att_list_type), pointer :: attList
+
+ type (att_list_type), pointer :: att_cursor
+
+ if (.not. associated(attList)) return
+
+ att_cursor => attList
+ if (ioDirection == MPAS_IO_WRITE) then
+ do while (associated(att_cursor))
+ select case (att_cursor % attType)
+ case (ATT_INT)
+ call MPAS_io_put_att(handle, trim(att_cursor % attName), att_cursor % attValueInt, fieldname)
+ case (ATT_INTA)
+ call MPAS_io_put_att(handle, trim(att_cursor % attName), att_cursor % attValueIntA, fieldname)
+ case (ATT_REAL)
+ call MPAS_io_put_att(handle, trim(att_cursor % attName), att_cursor % attValueReal, fieldname)
+ case (ATT_REALA)
+ call MPAS_io_put_att(handle, trim(att_cursor % attName), att_cursor % attValueRealA, fieldname)
+ case (ATT_TEXT)
+ call MPAS_io_put_att(handle, trim(att_cursor % attName), att_cursor % attValueText, fieldname)
+ end select
+ att_cursor => att_cursor % next
+ end do
+ else
+ do while (associated(att_cursor))
+ select case (att_cursor % attType)
+ case (ATT_INT)
+ call MPAS_io_get_att(handle, trim(att_cursor % attName), att_cursor % attValueInt, fieldname)
+ case (ATT_INTA)
+ call MPAS_io_get_att(handle, trim(att_cursor % attName), att_cursor % attValueIntA, fieldname)
+ case (ATT_REAL)
+ call MPAS_io_get_att(handle, trim(att_cursor % attName), att_cursor % attValueReal, fieldname)
+ case (ATT_REALA)
+ call MPAS_io_get_att(handle, trim(att_cursor % attName), att_cursor % attValueRealA, fieldname)
+ case (ATT_TEXT)
+ call MPAS_io_get_att(handle, trim(att_cursor % attName), att_cursor % attValueText, fieldname)
+ end select
+ att_cursor => att_cursor % next
+ end do
+ end if
+
+ end subroutine put_get_field_atts
+
+end module mpas_io_streams
Modified: trunk/mpas/src/registry/gen_inc.c
===================================================================
--- trunk/mpas/src/registry/gen_inc.c 2012-04-24 22:38:28 UTC (rev 1801)
+++ trunk/mpas/src/registry/gen_inc.c 2012-04-24 23:11:28 UTC (rev 1802)
@@ -14,6 +14,18 @@
return 0;
}
+
+void get_outer_dim(struct variable * var, char * last_dim)
+{
+ struct dimension_list * dimlist_ptr;
+
+
+ dimlist_ptr = var->dimlist;
+ while (dimlist_ptr->next) dimlist_ptr = dimlist_ptr->next;
+
+ strcpy(last_dim, dimlist_ptr->dim->name_in_file);
+}
+
void split_derived_dim_string(char * dim, char ** p1, char ** p2)
{
char * cp, * cm, * c;
@@ -164,12 +176,14 @@
struct variable * var_ptr2;
struct variable_list * var_list_ptr;
struct variable_list * var_list_ptr2;
+ struct variable_list * var_list_ptr3;
struct dimension * dim_ptr;
struct dimension_list * dimlist_ptr;
struct group_list * group_ptr;
FILE * fd;
char super_array[1024];
char array_class[1024];
+ char outer_dim[1024];
int i;
int class_start, class_end;
int vtype;
@@ -261,8 +275,8 @@
fd = fopen("read_dims.inc", "w");
dim_ptr = dims;
while (dim_ptr) {
- if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call mpas_io_input_get_dimension(input_obj, \'%s\', %s)</font>
<font color="red">", dim_ptr->name_in_file, dim_ptr->name_in_code);
- else if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call mpas_io_input_get_dimension(input_obj, \'%s\', %s)</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_file);
+ if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call MPAS_io_inq_dim(inputHandle, \'%s\', %s, ierr)</font>
<font color="blue">", dim_ptr->name_in_file, dim_ptr->name_in_code);
+ else if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s = %s</font>
<font color="gray">", dim_ptr->name_in_file, dim_ptr->name_in_code);
dim_ptr = dim_ptr->next;
}
@@ -360,6 +374,8 @@
if (strncmp(group_ptr->name, "mesh", 1024)) {
fortprintf(fd, " type %s_type</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " type (block_type), pointer :: block</font>
<font color="gray">");
+
var_list_ptr = group_ptr->vlist;
memcpy(super_array, var_list_ptr->var->super_array, 1024);
i = 1;
@@ -482,13 +498,13 @@
fortprintf(fd, " allocate(b %% %s %% time_levs(%i))</font>
<font color="black">", group_ptr->name, group_ptr->vlist->var->ntime_levs);
fortprintf(fd, " do i=1,b %% %s %% nTimeLevels</font>
<font color="black">", group_ptr->name);
fortprintf(fd, " allocate(b %% %s %% time_levs(i) %% %s)</font>
<font color="red">", group_ptr->name, group_ptr->name);
- fortprintf(fd, " call mpas_allocate_%s(b %% %s %% time_levs(i) %% %s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, " call mpas_allocate_%s(b, b %% %s %% time_levs(i) %% %s, &</font>
<font color="black">", group_ptr->name, group_ptr->name, group_ptr->name);
fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="black">");
fortprintf(fd, " )</font>
<font color="black">");
fortprintf(fd, " end do</font>
<font color="black"></font>
<font color="red">");
}
else {
- fortprintf(fd, " call mpas_allocate_%s(b %% %s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " call mpas_allocate_%s(b, b %% %s, &</font>
<font color="black">", group_ptr->name, group_ptr->name);
fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="black">");
fortprintf(fd, " )</font>
<font color="black"></font>
<font color="gray">");
}
@@ -520,16 +536,19 @@
fd = fopen("group_alloc_routines.inc", "w");
group_ptr = groups;
while (group_ptr) {
- fortprintf(fd, " subroutine mpas_allocate_%s(%s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " subroutine mpas_allocate_%s(b, %s, &</font>
<font color="black">", group_ptr->name, group_ptr->name);
fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="black">");
fortprintf(fd, " )</font>
<font color="black">");
fortprintf(fd, "</font>
<font color="black">");
fortprintf(fd, " implicit none</font>
<font color="black">");
fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (block_type), pointer :: b</font>
<font color="black">");
fortprintf(fd, " type (%s_type), intent(inout) :: %s</font>
<font color="black">", group_ptr->name, group_ptr->name);
fortprintf(fd, "#include \"dim_dummy_decls.inc\"</font>
<font color="black">");
fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " %s %% block => b</font>
<font color="gray">", group_ptr->name);
+
if (!strncmp(group_ptr->name, "mesh", 1024)) {
dim_ptr = dims;
while (dim_ptr) {
@@ -537,6 +556,7 @@
if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s %% %s = %s</font>
<font color="blue">", group_ptr->name, dim_ptr->name_in_file, dim_ptr->name_in_file);
dim_ptr = dim_ptr->next;
}
+
fortprintf(fd, "</font>
<font color="gray">");
}
@@ -556,6 +576,21 @@
var_ptr2 = var_list_ptr2->var;
fortprintf(fd, " allocate(%s %% %s)</font>
<font color="black">", group_ptr->name, var_ptr2->super_array);
fortprintf(fd, " allocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% fieldName = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% isSuperArray = .true.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " allocate(%s %% %s %% constituentNames(%i))</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i);
+
+ /* Initialization for constituent names */
+ i = 0;
+ var_list_ptr3 = group_ptr->vlist;
+ while (var_list_ptr3) {
+ if (strncmp(super_array, var_list_ptr3->var->super_array, 1024) == 0) {
+ i++;
+ fortprintf(fd, " %s %% %s %% constituentNames(%i) = \'%s\'</font>
<font color="gray">", group_ptr->name, var_ptr2->super_array, i, var_list_ptr3->var->name_in_file);
+ }
+ var_list_ptr3 = var_list_ptr3->next;
+ }
+
fortprintf(fd, " allocate(%s %% %s %% array(%i, ", group_ptr->name, var_ptr2->super_array, i);
dimlist_ptr = var_ptr2->dimlist;
if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
@@ -586,6 +621,42 @@
else if (var_ptr->vtype == CHARACTER)
fortprintf(fd, " %s %% %s %% array = \'\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
+ fortprintf(fd, " %s %% %s %% dimSizes(1) = %i</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i);
+ fortprintf(fd, " %s %% %s %% dimNames(1) = \'num_%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, var_ptr2->super_array);
+ dimlist_ptr = var_ptr2->dimlist;
+ i = 2;
+ while (dimlist_ptr) {
+ if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
+ if (!dimlist_ptr->dim->namelist_defined) {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ }
+ else {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ }
+ else
+ if (dimlist_ptr->dim->namelist_defined) {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ }
+ else {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ }
+ i++;
+ dimlist_ptr = dimlist_ptr->next;
+ }
+ if (var_ptr2->timedim) fortprintf(fd, " %s %% %s %% hasTimeDimension = .true.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ else fortprintf(fd, " %s %% %s %% hasTimeDimension = .false.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " nullify(%s %% %s %% prev)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " nullify(%s %% %s %% next)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " nullify(%s %% %s %% sendList)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " nullify(%s %% %s %% recvList)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " nullify(%s %% %s %% copyList)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+
if (var_ptr2->iostreams & INPUT0)
fortprintf(fd, " %s %% %s %% ioinfo %% input = .true.</font>
<font color="gray">", group_ptr->name, var_ptr2->super_array);
else
@@ -605,11 +676,15 @@
fortprintf(fd, " %s %% %s %% ioinfo %% output = .true.</font>
<font color="black">", group_ptr->name, var_ptr2->super_array);
else
fortprintf(fd, " %s %% %s %% ioinfo %% output = .false.</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+
+ fortprintf(fd, " %s %% %s %% block => b</font>
<font color="black">", group_ptr->name, var_ptr2->super_array);
fortprintf(fd, "</font>
<font color="black">");
}
else {
fortprintf(fd, " allocate(%s %% %s)</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, " allocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% fieldName = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_file);
+ fortprintf(fd, " %s %% %s %% isSuperArray = .false.</font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code);
if (var_ptr->ndims > 0) {
fortprintf(fd, " allocate(%s %% %s %% array(", group_ptr->name, var_ptr->name_in_code);
dimlist_ptr = var_ptr->dimlist;
@@ -641,7 +716,42 @@
else if (var_ptr->vtype == CHARACTER)
fortprintf(fd, " %s %% %s %% array = \'\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code ); /* initialize field to zero */
+ dimlist_ptr = var_ptr->dimlist;
+ i = 1;
+ while (dimlist_ptr) {
+ if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
+ if (!dimlist_ptr->dim->namelist_defined) {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ }
+ else {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ }
+ else
+ if (dimlist_ptr->dim->namelist_defined) {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ }
+ else {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ }
+ i++;
+ dimlist_ptr = dimlist_ptr->next;
+ }
}
+
+ if (var_ptr->timedim) fortprintf(fd, " %s %% %s %% hasTimeDimension = .true.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ else fortprintf(fd, " %s %% %s %% hasTimeDimension = .false.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " nullify(%s %% %s %% prev)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " nullify(%s %% %s %% next)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " nullify(%s %% %s %% sendList)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " nullify(%s %% %s %% recvList)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " nullify(%s %% %s %% copyList)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+
if (var_ptr->iostreams & INPUT0)
fortprintf(fd, " %s %% %s %% ioinfo %% input = .true.</font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code);
else
@@ -661,6 +771,8 @@
fortprintf(fd, " %s %% %s %% ioinfo %% output = .true.</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
else
fortprintf(fd, " %s %% %s %% ioinfo %% output = .false.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+
+ fortprintf(fd, " %s %% %s %% block => b</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, "</font>
<font color="gray">");
var_list_ptr = var_list_ptr->next;
@@ -697,16 +809,19 @@
}
fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="black">", group_ptr->name, var_list_ptr2->var->super_array);
fortprintf(fd, " deallocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_list_ptr2->var->super_array);
+ fortprintf(fd, " call mpas_deallocate_attlist(%s %% %s %% attList)</font>
<font color="black">", group_ptr->name, var_list_ptr2->var->super_array);
fortprintf(fd, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="black">", group_ptr->name, var_list_ptr2->var->super_array);
}
else {
if (var_ptr->ndims > 0) {
fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, " deallocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " call mpas_deallocate_attlist(%s %% %s %% attList)</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
}
else {
fortprintf(fd, " deallocate(%s %% %s %% ioinfo)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " call mpas_deallocate_attlist(%s %% %s %% attList)</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code);
}
var_list_ptr = var_list_ptr->next;
@@ -786,6 +901,142 @@
group_ptr = group_ptr->next;
}
fclose(fd);
+
+
+ /* Definitions of deallocate subroutines */
+ fd = fopen("field_links.inc", "w");
+
+ /* subroutine to call link subroutine for every field type */
+ fortprintf(fd, " subroutine mpas_create_field_links(b)</font>
<font color="black"></font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, " type (block_type), pointer :: b</font>
<font color="black"></font>
<font color="blue">");
+ group_ptr = groups;
+ while (group_ptr)
+ {
+ var_list_ptr = group_ptr->vlist;
+ var_list_ptr = var_list_ptr->next;
+ var_ptr = var_list_ptr->var;
+
+
+ int ntime_levs = 1;
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ {
+ memcpy(super_array, var_ptr->super_array, 1024);
+ memcpy(array_class, var_ptr->array_class, 1024);
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0)
+ {
+ var_list_ptr2 = var_list_ptr;
+ var_list_ptr = var_list_ptr->next;
+ }
+ var_ptr2 = var_list_ptr2->var;
+ get_outer_dim(var_ptr2, outer_dim);
+ ntime_levs = var_ptr2->ntime_levs;
+
+ if(ntime_levs > 1)
+ {
+ for(i=1; i<=ntime_levs; i++)
+ {
+ fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name, i, group_ptr->name);
+ }
+ }
+ else
+ {
+ fortprintf(fd, " call mpas_create_%s_links(b %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ }
+ }
+ else if (var_ptr->ndims > 0)
+ {
+ get_outer_dim(var_ptr, outer_dim);
+ ntime_levs = var_ptr->ntime_levs;
+
+ if(ntime_levs > 1)
+ {
+ for(i=1; i<=ntime_levs; i++)
+ {
+ fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name, i, group_ptr->name);
+ }
+ }
+ else
+ {
+ fortprintf(fd, " call mpas_create_%s_links(b %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ }
+ }
+
+ group_ptr = group_ptr->next;
+ }
+ fortprintf(fd, "</font>
<font color="black"> end subroutine mpas_create_field_links</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">");
+
+ /* subroutines for linking specific field type */
+ group_ptr = groups;
+
+ while (group_ptr) {
+ fortprintf(fd, " subroutine mpas_create_%s_links(%s)</font>
<font color="black"></font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), pointer :: %s</font>
<font color="black"></font>
<font color="blue">", group_ptr->name, group_ptr->name);
+
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ memcpy(super_array, var_ptr->super_array, 1024);
+ memcpy(array_class, var_ptr->array_class, 1024);
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ var_list_ptr2 = var_list_ptr;
+ var_list_ptr = var_list_ptr->next;
+ }
+ var_ptr2 = var_list_ptr2->var;
+ get_outer_dim(var_ptr2, outer_dim);
+
+ if (strncmp("nCells",outer_dim,1024) == 0) {
+ fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% cellsToSend</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% cellsToRecv</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% cellsToCopy</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ }
+ else if (strncmp("nEdges",outer_dim,1024) == 0) {
+ fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% edgesToSend</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% edgesToRecv</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% edgesToCopy</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ }
+ else if (strncmp("nVertices",outer_dim,1024) == 0) {
+ fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% verticesToSend</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% verticesToRecv</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% verticesToCopy</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, group_ptr->name, var_ptr2->super_array);
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+ }
+ else
+ {
+ if (var_ptr->ndims > 0)
+ {
+ get_outer_dim(var_ptr, outer_dim);
+
+ if (strncmp("nCells",outer_dim,1024) == 0) {
+ fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% cellsToSend</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% cellsToRecv</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% cellsToCopy</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ }
+ else if (strncmp("nEdges",outer_dim,1024) == 0) {
+ fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% edgesToSend</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% edgesToRecv</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% edgesToCopy</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ }
+ else if (strncmp("nVertices",outer_dim,1024) == 0) {
+ fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% verticesToSend</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% verticesToRecv</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% verticesToCopy</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code);
+ }
+ fortprintf(fd, "</font>
<font color="blue">");
+ }
+ var_list_ptr = var_list_ptr->next;
+ }
+ }
+
+ fortprintf(fd, " end subroutine mpas_create_%s_links</font>
<font color="black"></font>
<font color="black"></font>
<font color="gray">", group_ptr->name);
+
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
}
@@ -801,12 +1052,14 @@
FILE * fd;
char vtype[5];
char fname[32];
+ char super_array[1024];
char struct_deref[1024];
char * cp1, * cp2;
int i, j;
int ivtype;
+#ifdef LEGACY_CODE
/*
* Generate declarations of IDs belonging in io_input_object
*/
@@ -836,6 +1089,7 @@
fclose(fd);
+
/*
* Definitions of read bounds and exchange lists for non-decomposed fields
*/
@@ -1493,9 +1747,116 @@
}
fclose(fd);
+#endif
/*
+ * MGD NEW CODE
+ */
+ fd = fopen("add_input_fields.inc", "w");
+
+ group_ptr = groups;
+ while (group_ptr) {
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+
+ if (var_ptr->ntime_levs > 1)
+ snprintf(struct_deref, 1024, "blocklist %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name);
+ else
+ snprintf(struct_deref, 1024, "blocklist %% %s", group_ptr->name);
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ memcpy(super_array, var_ptr->super_array, 1024);
+/* fortprintf(fd, " write(0,*) \'adding input field %s\'</font>
<font color="blue">", var_ptr->super_array); */
+ fortprintf(fd, " call MPAS_streamAddField(input_obj %% io_stream, %s %% %s, nferr)</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ var_list_ptr = var_list_ptr->next;
+ }
+ }
+ else {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+/* fortprintf(fd, " write(0,*) \'adding input field %s\'</font>
<font color="blue">", var_ptr->name_in_code); */
+ fortprintf(fd, " call MPAS_streamAddField(input_obj %% io_stream, %s %% %s, nferr)</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ }
+
+ fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="blue">");
+
+ if (var_list_ptr) var_list_ptr = var_list_ptr->next;
+ }
+ group_ptr = group_ptr->next;
+ }
+
+ fclose(fd);
+
+
+ /*
+ * MGD NEW CODE
+ */
+ fd = fopen("exchange_input_field_halos.inc", "w");
+
+ group_ptr = groups;
+ while (group_ptr) {
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+
+ dimlist_ptr = var_ptr->dimlist;
+ i = 1;
+ while (dimlist_ptr) {
+ if (i == var_ptr->ndims) {
+ if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024)) {
+
+ if (var_ptr->ntime_levs > 1)
+ snprintf(struct_deref, 1024, "domain %% blocklist %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name);
+ else
+ snprintf(struct_deref, 1024, "domain %% blocklist %% %s", group_ptr->name);
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ memcpy(super_array, var_ptr->super_array, 1024);
+/* fortprintf(fd, " write(0,*) \'exchange halo for %s\'</font>
<font color="blue">", var_ptr->super_array); */
+ fortprintf(fd, " call mpas_dmpar_exch_halo_field(%s %% %s)</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ var_list_ptr = var_list_ptr->next;
+ }
+ }
+ else {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+/* fortprintf(fd, " write(0,*) \'exchange halo for %s\'</font>
<font color="blue">", var_ptr->name_in_code); */
+ fortprintf(fd, " call mpas_dmpar_exch_halo_field(%s %% %s)</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ }
+
+ fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="gray">");
+
+ }
+ }
+
+ i++;
+ dimlist_ptr = dimlist_ptr -> next;
+ }
+
+ if (var_list_ptr) var_list_ptr = var_list_ptr->next;
+ }
+ group_ptr = group_ptr->next;
+ }
+
+ fclose(fd);
+
+
+#ifdef LEGACY_CODE
+ /*
* Generate NetCDF reads of dimension and variable IDs
*/
fd = fopen("netcdf_read_ids.inc", "w");
@@ -1657,6 +2018,7 @@
fclose(fd);
}
+#endif
}
@@ -1674,11 +2036,13 @@
char vtype[5];
char fname[32];
char struct_deref[1024];
+ char super_array[1024];
char * cp1, * cp2;
int i, j;
int ivtype;
+#ifdef LEGACY_CODE
/*
* Generate declarations of IDs belonging in io_output_object
*/
@@ -1818,9 +2182,77 @@
}
fclose(fd);
+#endif
+
+
+ /*
+ * MGD NEW CODE
+ */
+ fd = fopen("add_output_fields.inc", "w");
+
+ group_ptr = groups;
+ while (group_ptr) {
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+
+ if (group_ptr->vlist->var->ntime_levs > 1)
+ snprintf(struct_deref, 1024, "domain %% blocklist %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name);
+ else
+ snprintf(struct_deref, 1024, "domain %% blocklist %% %s", group_ptr->name);
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. output_obj %% stream == SFC)) then</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ memcpy(super_array, var_ptr->super_array, 1024);
+ fortprintf(fd, " call MPAS_streamAddField(output_obj %% io_stream, %s %% %s, ierr)</font>
<font color="blue">", struct_deref, super_array);
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
+ var_list_ptr = var_list_ptr->next;
+ }
+ }
+ else {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. output_obj %% stream == SFC)) then</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " call MPAS_streamAddField(output_obj %% io_stream, %s %% %s, ierr)</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ }
+ fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="blue">");
+ if (var_list_ptr) var_list_ptr = var_list_ptr->next;
+ }
+ group_ptr = group_ptr->next;
+ }
+
+ fclose(fd);
+
+
/*
+ * MGD NEW CODE
+ */
+ fd = fopen("add_output_atts.inc", "w");
+
+ nl = namelists;
+ while (nl) {
+ if (nl->vtype == LOGICAL) {
+ fortprintf(fd, " if (%s) then</font>
<font color="blue">", nl->name);
+ fortprintf(fd, " call MPAS_writeStreamAtt(output_obj %% io_stream, \'%s\', 'T', ierr)</font>
<font color="blue">", nl->name);
+ fortprintf(fd, " else</font>
<font color="blue">");
+ fortprintf(fd, " call MPAS_writeStreamAtt(output_obj %% io_stream, \'%s\', 'F', ierr)</font>
<font color="blue">", nl->name);
+ fortprintf(fd, " end if</font>
<font color="blue">");
+ }
+ else {
+ fortprintf(fd, " call MPAS_writeStreamAtt(output_obj %% io_stream, \'%s\', %s, ierr)</font>
<font color="gray">", nl->name, nl->name);
+ }
+ nl = nl->next;
+ }
+
+ fclose(fd);
+
+
+#ifdef LEGACY_CODE
+ /*
* Generate collect and write code
*/
fd = fopen("io_output_fields.inc", "w");
@@ -2194,5 +2626,6 @@
fclose(fd);
}
+#endif
}
</font>
</pre>