<p><b>qchen3@fsu.edu</b> 2010-10-22 13:14:07 -0600 (Fri, 22 Oct 2010)</p><p>I have merged the latest changes into the branch swmodel_del4.<br>
</p><hr noshade><pre><font color="gray">Modified: branches/swmodel_del4/Makefile
===================================================================
--- branches/swmodel_del4/Makefile 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/Makefile 2010-10-22 19:14:07 UTC (rev 578)
@@ -1,10 +1,6 @@
#MODEL_FORMULATION = -DNCAR_FORMULATION
MODEL_FORMULATION = -DLANL_FORMULATION
-ifeq ($(CORE),hyd_atmos)
-EXPAND_LEVELS = -DEXPAND_LEVELS=26
-endif
-
#FILE_OFFSET = -DOFFSET64BIT
#########################
@@ -34,7 +30,7 @@
"CFLAGS = -g" \
"LDFLAGS = -g -C" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
ftn:
( make all \
@@ -46,7 +42,7 @@
"CFLAGS = -fast" \
"LDFLAGS = " \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
pgi:
( make all \
@@ -58,7 +54,7 @@
"CFLAGS = -O3" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
pgi-llnl:
( make all \
@@ -70,7 +66,7 @@
"CFLAGS = -fast" \
"LDFLAGS = " \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
pgi-serial:
( make all \
@@ -82,7 +78,7 @@
"CFLAGS = -O0 -g" \
"LDFLAGS = -O0 -g -Mbounds -Mchkptr" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
ifort:
( make all \
@@ -94,7 +90,7 @@
"CFLAGS = -O3 -m64" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
gfortran:
( make all \
@@ -106,7 +102,7 @@
"CFLAGS = -O3 -m64" \
"LDFLAGS = -O3 -m64" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
gfortran-serial:
( make all \
@@ -130,7 +126,7 @@
"CFLAGS = -O3" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
g95-serial:
( make all \
@@ -142,7 +138,7 @@
"CFLAGS = -O3" \
"LDFLAGS = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(EXPAND_LEVELS) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
CPPINCLUDES = -I../inc -I$(NETCDF)/include
Modified: branches/swmodel_del4/namelist.input.hyd_atmos
===================================================================
--- branches/swmodel_del4/namelist.input.hyd_atmos 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/namelist.input.hyd_atmos 2010-10-22 19:14:07 UTC (rev 578)
@@ -16,6 +16,10 @@
config_mp_physics = 0
/
+&dimensions
+ config_nvertlevels = 26
+/
+
&io
config_input_name = 'grid.nc'
config_output_name = 'output.nc'
Modified: branches/swmodel_del4/namelist.input.ocean
===================================================================
--- branches/swmodel_del4/namelist.input.ocean 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/namelist.input.ocean 2010-10-22 19:14:07 UTC (rev 578)
@@ -42,6 +42,9 @@
config_vert_diffusion = 1.0e-4
/
&advection
- config_hor_tracer_adv = 'centered'
- config_vert_tracer_adv = 'centered'
+ config_vert_tracer_adv = 'upwind'
+ config_tracer_adv_order = 2
+ config_thickness_adv_order = 2
+ config_positive_definite = .false.
+ config_monotonic = .false.
/
Modified: branches/swmodel_del4/namelist.input.sw
===================================================================
--- branches/swmodel_del4/namelist.input.sw 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/namelist.input.sw 2010-10-22 19:14:07 UTC (rev 578)
@@ -6,9 +6,13 @@
config_output_interval = 500
config_stats_interval = 0
config_h_mom_eddy_visc2 = 0.0
- config_h_mom_eddy_visc4 = 1000000000000.0
+ config_h_mom_eddy_visc4 = 0.0
config_h_tracer_eddy_diff2 = 0.0
config_h_tracer_eddy_diff4 = 0.0
+ config_thickness_adv_order = 2
+ config_tracer_adv_order = 2
+ config_positive_definite = .false.
+ config_monotonic = .false.
/
&io
Modified: branches/swmodel_del4/src/core_hyd_atmos/Registry
===================================================================
--- branches/swmodel_del4/src/core_hyd_atmos/Registry 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_hyd_atmos/Registry 2010-10-22 19:14:07 UTC (rev 578)
@@ -18,6 +18,7 @@
namelist logical sw_model config_positive_definite false
namelist logical sw_model config_monotonic true
namelist integer sw_model config_mp_physics 0
+namelist integer dimensions config_nvertlevels 26
namelist character io config_input_name grid.nc
namelist character io config_output_name output.nc
namelist character io config_restart_name restart.nc
@@ -38,132 +39,142 @@
dim FIFTEEN 15
dim TWENTYONE 21
dim R3 3
-dim nVertLevels nVertLevels
+#dim nVertLevels nVertLevels
+dim nVertLevels namelist:config_nvertlevels
#dim nTracers nTracers
dim nVertLevelsP1 nVertLevels+1
#
-# var type name_in_file ( dims ) iro- name_in_code super-array array_class
+# var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
#
-var real xtime ( Time ) ro xtime - -
+var persistent real xtime ( Time ) 2 ro xtime state - -
-var real latCell ( nCells ) iro latCell - -
-var real lonCell ( nCells ) iro lonCell - -
-var real xCell ( nCells ) iro xCell - -
-var real yCell ( nCells ) iro yCell - -
-var real zCell ( nCells ) iro zCell - -
-var integer indexToCellID ( nCells ) iro indexToCellID - -
+var persistent real latCell ( nCells ) 0 iro latCell mesh - -
+var persistent real lonCell ( nCells ) 0 iro lonCell mesh - -
+var persistent real xCell ( nCells ) 0 iro xCell mesh - -
+var persistent real yCell ( nCells ) 0 iro yCell mesh - -
+var persistent real zCell ( nCells ) 0 iro zCell mesh - -
+var persistent integer indexToCellID ( nCells ) 0 iro indexToCellID mesh - -
-var real latEdge ( nEdges ) iro latEdge - -
-var real lonEdge ( nEdges ) iro lonEdge - -
-var real xEdge ( nEdges ) iro xEdge - -
-var real yEdge ( nEdges ) iro yEdge - -
-var real zEdge ( nEdges ) iro zEdge - -
-var integer indexToEdgeID ( nEdges ) iro indexToEdgeID - -
+var persistent real latEdge ( nEdges ) 0 iro latEdge mesh - -
+var persistent real lonEdge ( nEdges ) 0 iro lonEdge mesh - -
+var persistent real xEdge ( nEdges ) 0 iro xEdge mesh - -
+var persistent real yEdge ( nEdges ) 0 iro yEdge mesh - -
+var persistent real zEdge ( nEdges ) 0 iro zEdge mesh - -
+var persistent integer indexToEdgeID ( nEdges ) 0 iro indexToEdgeID mesh - -
-var real latVertex ( nVertices ) iro latVertex - -
-var real lonVertex ( nVertices ) iro lonVertex - -
-var real xVertex ( nVertices ) iro xVertex - -
-var real yVertex ( nVertices ) iro yVertex - -
-var real zVertex ( nVertices ) iro zVertex - -
-var integer indexToVertexID ( nVertices ) iro indexToVertexID - -
+var persistent real latVertex ( nVertices ) 0 iro latVertex mesh - -
+var persistent real lonVertex ( nVertices ) 0 iro lonVertex mesh - -
+var persistent real xVertex ( nVertices ) 0 iro xVertex mesh - -
+var persistent real yVertex ( nVertices ) 0 iro yVertex mesh - -
+var persistent real zVertex ( nVertices ) 0 iro zVertex mesh - -
+var persistent integer indexToVertexID ( nVertices ) 0 iro indexToVertexID mesh - -
-var integer cellsOnEdge ( TWO nEdges ) iro cellsOnEdge - -
-var integer nEdgesOnCell ( nCells ) iro nEdgesOnCell - -
-var integer nEdgesOnEdge ( nEdges ) iro nEdgesOnEdge - -
-var integer edgesOnCell ( maxEdges nCells ) iro edgesOnCell - -
-var integer edgesOnEdge ( maxEdges2 nEdges ) iro edgesOnEdge - -
+var persistent integer cellsOnEdge ( TWO nEdges ) 0 iro cellsOnEdge mesh - -
+var persistent integer nEdgesOnCell ( nCells ) 0 iro nEdgesOnCell mesh - -
+var persistent integer nEdgesOnEdge ( nEdges ) 0 iro nEdgesOnEdge mesh - -
+var persistent integer edgesOnCell ( maxEdges nCells ) 0 iro edgesOnCell mesh - -
+var persistent integer edgesOnEdge ( maxEdges2 nEdges ) 0 iro edgesOnEdge mesh - -
-var real weightsOnEdge ( maxEdges2 nEdges ) iro weightsOnEdge - -
-var real dvEdge ( nEdges ) iro dvEdge - -
-var real dcEdge ( nEdges ) iro dcEdge - -
-var real angleEdge ( nEdges ) iro angleEdge - -
-var real areaCell ( nCells ) iro areaCell - -
-var real areaTriangle ( nVertices ) iro areaTriangle - -
+var persistent real weightsOnEdge ( maxEdges2 nEdges ) 0 iro weightsOnEdge mesh - -
+var persistent real dvEdge ( nEdges ) 0 iro dvEdge mesh - -
+var persistent real dcEdge ( nEdges ) 0 iro dcEdge mesh - -
+var persistent real angleEdge ( nEdges ) 0 iro angleEdge mesh - -
+var persistent real areaCell ( nCells ) 0 iro areaCell mesh - -
+var persistent real areaTriangle ( nVertices ) 0 iro areaTriangle mesh - -
-var real edgeNormalVectors ( R3 nEdges ) o edgeNormalVectors - -
-var real localVerticalUnitVectors ( R3 nCells ) o localVerticalUnitVectors - -
-var real cellTangentPlane ( R3 TWO nEdges ) o cellTangentPlane - -
+var persistent real edgeNormalVectors ( R3 nEdges ) 0 o edgeNormalVectors mesh - -
+var persistent real localVerticalUnitVectors ( R3 nCells ) 0 o localVerticalUnitVectors mesh - -
+var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 o cellTangentPlane mesh - -
-var integer cellsOnCell ( maxEdges nCells ) iro cellsOnCell - -
-var integer verticesOnCell ( maxEdges nCells ) iro verticesOnCell - -
-var integer verticesOnEdge ( TWO nEdges ) iro verticesOnEdge - -
-var integer edgesOnVertex ( vertexDegree nVertices ) iro edgesOnVertex - -
-var integer cellsOnVertex ( vertexDegree nVertices ) iro cellsOnVertex - -
-var real kiteAreasOnVertex ( vertexDegree nVertices ) iro kiteAreasOnVertex - -
-var real fEdge ( nEdges ) iro fEdge - -
-var real fVertex ( nVertices ) iro fVertex - -
-var real h_s ( nCells ) iro h_s - -
+var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
+var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
+var persistent integer verticesOnEdge ( TWO nEdges ) 0 iro verticesOnEdge mesh - -
+var persistent integer edgesOnVertex ( vertexDegree nVertices ) 0 iro edgesOnVertex mesh - -
+var persistent integer cellsOnVertex ( vertexDegree nVertices ) 0 iro cellsOnVertex mesh - -
+var persistent real kiteAreasOnVertex ( vertexDegree nVertices ) 0 iro kiteAreasOnVertex mesh - -
+var persistent real fEdge ( nEdges ) 0 iro fEdge mesh - -
+var persistent real fVertex ( nVertices ) 0 iro fVertex mesh - -
+var persistent real h_s ( nCells ) 0 iro h_s mesh - -
# description of the vertical grid structure
-var real rdnu ( nVertLevels ) iro rdnu - -
-var real rdnw ( nVertLevels ) iro rdnw - -
-var real fnm ( nVertLevels ) iro fnm - -
-var real fnp ( nVertLevels ) iro fnp - -
-var real dbn ( nVertLevels ) iro dbn - -
-var real dnu ( nVertLevels ) iro dnu - -
-var real dnw ( nVertLevels ) iro dnw - -
+var persistent real rdnu ( nVertLevels ) 0 iro rdnu mesh - -
+var persistent real rdnw ( nVertLevels ) 0 iro rdnw mesh - -
+var persistent real fnm ( nVertLevels ) 0 iro fnm mesh - -
+var persistent real fnp ( nVertLevels ) 0 iro fnp mesh - -
+var persistent real dbn ( nVertLevels ) 0 iro dbn mesh - -
+var persistent real dnu ( nVertLevels ) 0 iro dnu mesh - -
+var persistent real dnw ( nVertLevels ) 0 iro dnw mesh - -
# Prognostic variables: read from input, saved in restart, and written to output
-var real u ( nVertLevels nEdges Time ) iro u - -
-var real theta ( nVertLevels nCells Time ) iro theta - -
-var real surface_pressure ( nCells Time ) iro surface_pressure - -
-var real qv ( nVertLevels nCells Time ) iro qv scalars moist
-var real qc ( nVertLevels nCells Time ) iro qc scalars moist
-var real qr ( nVertLevels nCells Time ) iro qr scalars moist
-#var real tracers ( nTracers nVertLevels nCells Time ) iro tracers - -
+var persistent real u ( nVertLevels nEdges Time ) 2 iro u state - -
+var persistent real theta ( nVertLevels nCells Time ) 2 iro theta state - -
+var persistent real surface_pressure ( nCells Time ) 2 iro surface_pressure state - -
+var persistent real qv ( nVertLevels nCells Time ) 2 iro qv state scalars moist
+var persistent real qc ( nVertLevels nCells Time ) 2 iro qc state scalars moist
+var persistent real qr ( nVertLevels nCells Time ) 2 iro qr state scalars moist
+#var persistent real tracers ( nTracers nVertLevels nCells Time ) 2 iro state tracers - -
# state variables diagnosed from prognostic state
-var real h ( nVertLevels nCells Time ) ro h - -
-var real ww ( nVertLevelsP1 nCells Time ) ro ww - -
-var real w ( nVertLevelsP1 nCells Time ) ro w - -
-var real pressure ( nVertLevelsP1 nCells Time ) ro pressure - -
-var real geopotential ( nVertLevelsP1 nCells Time ) ro geopotential - -
-var real alpha ( nVertLevels nCells Time ) iro alpha - -
+var persistent real h ( nVertLevels nCells Time ) 2 ro h state - -
+var persistent real ww ( nVertLevelsP1 nCells Time ) 2 ro ww state - -
+var persistent real w ( nVertLevelsP1 nCells Time ) 2 ro w state - -
+var persistent real pressure ( nVertLevelsP1 nCells Time ) 2 ro pressure state - -
+var persistent real geopotential ( nVertLevelsP1 nCells Time ) 2 ro geopotential state - -
+var persistent real alpha ( nVertLevels nCells Time ) 2 iro alpha state - -
# Diagnostic fields: only written to output
-var real v ( nVertLevels nEdges Time ) o v - -
-var real divergence ( nVertLevels nCells Time ) o divergence - -
-var real vorticity ( nVertLevels nVertices Time ) o vorticity - -
-var real pv_edge ( nVertLevels nEdges Time ) o pv_edge - -
-var real h_edge ( nVertLevels nEdges Time ) o h_edge - -
-var real ke ( nVertLevels nCells Time ) o ke - -
-var real pv_vertex ( nVertLevels nVertices Time ) o pv_vertex - -
-var real pv_cell ( nVertLevels nCells Time ) o pv_cell - -
-var real uReconstructX ( nVertLevels nCells Time ) o uReconstructX - -
-var real uReconstructY ( nVertLevels nCells Time ) o uReconstructY - -
-var real uReconstructZ ( nVertLevels nCells Time ) o uReconstructZ - -
-var real uReconstructZonal ( nVertLevels nCells Time ) o uReconstructZonal - -
-var real uReconstructMeridional ( nVertLevels nCells Time ) o uReconstructMeridional - -
+var persistent real v ( nVertLevels nEdges Time ) 2 o v state - -
+var persistent real divergence ( nVertLevels nCells Time ) 2 o divergence state - -
+var persistent real vorticity ( nVertLevels nVertices Time ) 2 o vorticity state - -
+var persistent real pv_edge ( nVertLevels nEdges Time ) 2 o pv_edge state - -
+var persistent real h_edge ( nVertLevels nEdges Time ) 2 o h_edge state - -
+var persistent real ke ( nVertLevels nCells Time ) 2 o ke state - -
+var persistent real pv_vertex ( nVertLevels nVertices Time ) 2 o pv_vertex state - -
+var persistent real pv_cell ( nVertLevels nCells Time ) 2 o pv_cell state - -
+var persistent real uReconstructX ( nVertLevels nCells Time ) 2 o uReconstructX state - -
+var persistent real uReconstructY ( nVertLevels nCells Time ) 2 o uReconstructY state - -
+var persistent real uReconstructZ ( nVertLevels nCells Time ) 2 o uReconstructZ state - -
+var persistent real uReconstructZonal ( nVertLevels nCells Time ) 2 o uReconstructZonal state - -
+var persistent real uReconstructMeridional ( nVertLevels nCells Time ) 2 o uReconstructMeridional state - -
+# Tendency variables
+var persistent real tend_h ( nVertLevels nCells Time ) 1 - h tend - -
+var persistent real tend_u ( nVertLevels nEdges Time ) 1 - u tend - -
+var persistent real tend_vh ( nVertLevels nEdges Time ) 1 - vh tend - -
+var persistent real tend_theta ( nVertLevels nCells Time ) 1 - theta tend - -
+var persistent real tend_qv ( nVertLevels nCells Time ) 1 - qv tend scalars moist
+var persistent real tend_qc ( nVertLevels nCells Time ) 1 - qc tend scalars moist
+var persistent real tend_qr ( nVertLevels nCells Time ) 1 - qr tend scalars moist
+
# Other diagnostic variables: neither read nor written to any files
-var real vh ( nVertLevels nEdges Time ) - vh - -
-var real circulation ( nVertLevels nVertices Time ) - circulation - -
-var real gradPVt ( nVertLevels nEdges Time ) - gradPVt - -
-var real gradPVn ( nVertLevels nEdges Time ) - gradPVn - -
+var persistent real vh ( nVertLevels nEdges Time ) 2 - vh state - -
+var persistent real circulation ( nVertLevels nVertices Time ) 2 - circulation state - -
+var persistent real gradPVt ( nVertLevels nEdges Time ) 2 - gradPVt state - -
+var persistent real gradPVn ( nVertLevels nEdges Time ) 2 - gradPVn state - -
-var real uhAvg ( nVertLevels nEdges ) - uhAvg - -
-var real wwAvg ( nVertLevelsP1 nCells ) - wwAvg - -
-var real qtot ( nVertLevels nCells ) - qtot - -
-var real cqu ( nVertLevels nEdges ) - cqu - -
-var real h_diabatic ( nVertLevels nCells ) - h_diabatic - -
-var real dpsdt ( nCells ) - dpsdt - -
+var persistent real uhAvg ( nVertLevels nEdges ) 0 - uhAvg mesh - -
+var persistent real wwAvg ( nVertLevelsP1 nCells ) 0 - wwAvg mesh - -
+var persistent real qtot ( nVertLevels nCells ) 0 - qtot mesh - -
+var persistent real cqu ( nVertLevels nEdges ) 0 - cqu mesh - -
+var persistent real h_diabatic ( nVertLevels nCells ) 0 - h_diabatic mesh - -
+var persistent real dpsdt ( nCells ) 0 - dpsdt mesh - -
-var real u_old ( nVertLevels nEdges ) - u_old - -
-var real ww_old ( nVertLevelsP1 nCells ) - ww_old - -
-var real theta_old ( nVertLevels nCells ) - theta_old - -
-var real h_edge_old ( nVertLevels nEdges ) - h_edge_old - -
-var real h_old ( nVertLevels nCells ) - h_old - -
-var real pressure_old ( nVertLevelsP1 nCells ) - pressure_old - -
-var real qv_old ( nVertLevels nCells ) - qv_old scalars_old moist_old
-var real qc_old ( nVertLevels nCells ) - qc_old scalars_old moist_old
-var real qr_old ( nVertLevels nCells ) - qr_old scalars_old moist_old
-#var real tracers_old ( nTracers nVertLevels nCells ) - tracers_old - -
+var persistent real u_old ( nVertLevels nEdges ) 0 - u_old mesh - -
+var persistent real ww_old ( nVertLevelsP1 nCells ) 0 - ww_old mesh - -
+var persistent real theta_old ( nVertLevels nCells ) 0 - theta_old mesh - -
+var persistent real h_edge_old ( nVertLevels nEdges ) 0 - h_edge_old mesh - -
+var persistent real h_old ( nVertLevels nCells ) 0 - h_old mesh - -
+var persistent real pressure_old ( nVertLevelsP1 nCells ) 0 - pressure_old mesh - -
+var persistent real qv_old ( nVertLevels nCells ) 0 - qv_old mesh scalars_old moist_old
+var persistent real qc_old ( nVertLevels nCells ) 0 - qc_old mesh scalars_old moist_old
+var persistent real qr_old ( nVertLevels nCells ) 0 - qr_old mesh scalars_old moist_old
+#var persistent real tracers_old ( nTracers nVertLevels nCells ) 0 - tracers_old mesh - -
# Space needed for advection
-var real deriv_two ( FIFTEEN TWO nEdges ) o deriv_two - -
-var integer advCells ( TWENTYONE nCells ) - advCells - -
+var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 o deriv_two mesh - -
+var persistent integer advCells ( TWENTYONE nCells ) 0 - advCells mesh - -
# Arrays required for reconstruction of velocity field
-var real coeffs_reconstruct ( R3 maxEdges nCells ) - coeffs_reconstruct - -
+var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 - coeffs_reconstruct mesh - -
Modified: branches/swmodel_del4/src/core_hyd_atmos/module_advection.F
===================================================================
--- branches/swmodel_del4/src/core_hyd_atmos/module_advection.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_hyd_atmos/module_advection.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -17,7 +17,7 @@
!
implicit none
- type (grid_meta), intent(in) :: grid
+ type (mesh_type), intent(in) :: grid
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
integer, dimension(:,:), pointer :: advCells
Modified: branches/swmodel_del4/src/core_hyd_atmos/module_test_cases.F
===================================================================
--- branches/swmodel_del4/src/core_hyd_atmos/module_test_cases.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_hyd_atmos/module_test_cases.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -35,9 +35,9 @@
if (config_test_case == 3) write(0,*) ' normal-mode perturbation included '
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call hyd_test_case_1(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
+ call hyd_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state, config_test_case)
do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
+ call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
end do
block_ptr => block_ptr % next
@@ -59,8 +59,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
integer, intent(in) :: test_case
real (kind=RKIND), parameter :: u0 = 35.0
@@ -78,7 +78,7 @@
real (kind=RKIND), dimension(:,:), pointer :: pressure, theta, alpha, geopotential, h
real (kind=RKIND), dimension(:,:,:), pointer :: scalars
- integer :: iCell, iEdge, vtx1, vtx2, ivtx, k, nz, nz1
+ integer :: iCell, iEdge, vtx1, vtx2, ivtx, k, nz, nz1, index_qv
real (kind=RKIND) :: u, v, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r
real (kind=RKIND) :: ptop, p0, phi
@@ -129,6 +129,8 @@
grid % areaCell % array = grid % areaCell % array * a**2.0
grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ index_qv = state % index_qv
nz1 = grid % nVertLevels
nz = nz1 + 1
Modified: branches/swmodel_del4/src/core_hyd_atmos/module_time_integration.F
===================================================================
--- branches/swmodel_del4/src/core_hyd_atmos/module_time_integration.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_hyd_atmos/module_time_integration.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -37,7 +37,7 @@
block => domain % blocklist
do while (associated(block))
- block % time_levs(2) % state % xtime % scalar = block % time_levs(1) % state % xtime % scalar + dt
+ block % state % time_levs(2) % state % xtime % scalar = block % state % time_levs(1) % state % xtime % scalar + dt
block => block % next
end do
@@ -100,7 +100,7 @@
block => domain % blocklist
do while (associated(block))
- call copy_state( block % time_levs(1) % state, block % time_levs(2) % state )
+ call copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
block => block % next
end do
@@ -121,26 +121,26 @@
call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % cqu % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % h % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % pressure % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
block % mesh % nVertLevels+1, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % geopotential % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
block % mesh % nVertLevels+1, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % alpha % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % pv_edge % array(:,:), &
+ call dmpar_exch_halo_field2dReal(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 dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % divergence % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % vorticity % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
block % mesh % nVertLevels, block % mesh % nVertices, &
block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
end if
@@ -151,7 +151,7 @@
block => domain % blocklist
do while (associated(block))
- call compute_dyn_tend( block % intermediate_step(TEND), block % time_levs(2) % state, block % mesh )
+ call compute_dyn_tend( block % tend, block % state % time_levs(2) % state, block % mesh )
block => block % next
end do
@@ -162,10 +162,10 @@
!
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(TEND) % u % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % u % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(TEND) % theta % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % theta % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
block => block % next
@@ -181,9 +181,9 @@
! from the previous RK step are needed to compute new scalar tendencies in advance_scalars.
! A cleaner way of preserving scalars should be added in future.
!
- block % mesh % scalars_old % array(:,:,:) = block % time_levs(2) % state % scalars % array(:,:,:)
- call copy_state( block % time_levs(1) % state, block % time_levs(2) % state )
- block % time_levs(2) % state % scalars % array(:,:,:) = block % mesh % scalars_old % array(:,:,:)
+ block % mesh % scalars_old % array(:,:,:) = block % state % time_levs(2) % state % scalars % array(:,:,:)
+ call copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
+ block % state % time_levs(2) % state % scalars % array(:,:,:) = block % mesh % scalars_old % array(:,:,:)
block => block % next
end do
@@ -195,8 +195,8 @@
block => domain % blocklist
do while (associated(block))
- call advance_dynamics( block % intermediate_step(TEND), block % time_levs(2) % state, &
- block % mesh, &
+ call advance_dynamics( block % tend, block % state % time_levs(2) % state, &
+ block % mesh, &
small_step, number_sub_steps(rk_step), rk_sub_timestep(rk_step) )
block => block % next
end do
@@ -209,10 +209,10 @@
!
block => domain % blocklist
do while (associated(block))
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % u % array(:,:), &
+!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % u % array(:,:), &
!! block % mesh % nVertLevels, block % mesh % nEdges, &
!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % h_edge % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % h_edge % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % uhAvg % array(:,:), &
@@ -221,34 +221,34 @@
!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % wwAvg % array(:,:), &
!! block % mesh % nVertLevels+1, block % mesh % nCells, &
!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % theta % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % theta % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % h % array(:,:), &
+!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
!! block % mesh % nVertLevels, block % mesh % nCells, &
!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(TEND) % h % array(:,:), &
+!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % h % array(:,:), &
!! block % mesh % nVertLevels, block % mesh % nCells, &
!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
call dmpar_exch_halo_field1dReal(domain % dminfo, block % mesh % dpsdt % array(:), &
block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field1dReal(domain % dminfo, block % time_levs(2) % state % surface_pressure % array(:), &
+ call dmpar_exch_halo_field1dReal(domain % dminfo, block % state % time_levs(2) % state % surface_pressure % array(:), &
block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % alpha % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % ww % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % ww % array(:,:), &
block % mesh % nVertLevels+1, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % pressure % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
block % mesh % nVertLevels+1, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
!! call dmpar_exch_halo_field2dReal(domain % dminfo, block % mesh % pressure_old % array(:,:), &
!! block % mesh % nVertLevels+1, block % mesh % nCells, &
!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % geopotential % array(:,:), &
+ call dmpar_exch_halo_field2dReal(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
@@ -269,13 +269,13 @@
! so we keep the advance_scalars routine as well
!
if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then
- call advance_scalars( block % intermediate_step(TEND), &
- block % time_levs(1) % state, block % time_levs(2) % state, &
+ call advance_scalars( block % tend, &
+ block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
block % mesh, rk_timestep(rk_step) )
else
- call advance_scalars_mono( block % intermediate_step(TEND), &
- block % time_levs(1) % state, block % time_levs(2) % state, &
- block % mesh, rk_timestep(rk_step), rk_step, 3, &
+ call 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 )
end if
block => block % next
@@ -283,11 +283,11 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % intermediate_step(TEND) % scalars % array(:,:,:), &
- num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
+ call dmpar_exch_halo_field3dReal(domain % dminfo, block % tend % scalars % array(:,:,:), &
+ block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % time_levs(2) % state % scalars % array(:,:,:), &
- num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
+ call dmpar_exch_halo_field3dReal(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
@@ -299,9 +299,9 @@
block => domain % blocklist
do while (associated(block))
- call compute_solver_constants( block % time_levs(2) % state, block % mesh )
- call compute_state_diagnostics( block % time_levs(2) % state, block % mesh )
- call compute_solve_diagnostics( dt, block % time_levs(2) % state, block % mesh )
+ call compute_solver_constants( block % state % time_levs(2) % state, block % mesh )
+ call compute_state_diagnostics( block % state % time_levs(2) % state, block % mesh )
+ call compute_solve_diagnostics( dt, block % state % time_levs(2) % state, block % mesh )
block => block % next
end do
@@ -320,8 +320,8 @@
!
block => domain % blocklist
do while (associated(block))
- call reconstruct(block % time_levs(2) % state, block % mesh)
- call compute_w(block % time_levs(2) % state, block % time_levs(1) % state, block % mesh, dt)
+ call reconstruct(block % state % time_levs(2) % state, block % mesh)
+ call compute_w(block % state % time_levs(2) % state, block % state % time_levs(1) % state, block % mesh, dt)
block => block % next
end do
@@ -331,21 +331,21 @@
domain_mass = 0.
scalar_mass = 0.
block => domain % blocklist
- scalar_min = block % time_levs(2) % state % scalars % array (2,1,1)
- scalar_max = block % time_levs(2) % state % scalars % array (2,1,1)
+ scalar_min = block % state % time_levs(2) % state % scalars % array (2,1,1)
+ scalar_max = block % state % time_levs(2) % state % scalars % array (2,1,1)
do while(associated(block))
do iCell = 1, block % mesh % nCellsSolve
- domain_mass = domain_mass + block % time_levs(2) % state % surface_pressure % array (iCell) * &
+ domain_mass = domain_mass + block % state % time_levs(2) % state % surface_pressure % array (iCell) * &
block % mesh % areaCell % array (iCell) &
- - block % time_levs(2) % state % pressure % array (block % mesh % nVertLevels + 1, 1) * &
+ - block % state % time_levs(2) % state % pressure % array (block % mesh % nVertLevels + 1, 1) * &
block % mesh % areaCell % array (iCell)
do k=1, block % mesh % nVertLevelsSolve
- scalar_mass = scalar_mass - block % time_levs(2) % state % scalars % array (2,k,iCell) * &
- block % time_levs(2) % state % h % array (k,iCell) * &
+ scalar_mass = scalar_mass - block % state % time_levs(2) % state % scalars % array (2,k,iCell) * &
+ block % state % time_levs(2) % state % h % array (k,iCell) * &
block % mesh % dnw % array (k) * &
block % mesh % areaCell % array (iCell)
- scalar_min = min(scalar_min,block % time_levs(2) % state % scalars % array (2,k,iCell))
- scalar_max = max(scalar_max,block % time_levs(2) % state % scalars % array (2,k,iCell))
+ scalar_min = min(scalar_min,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
+ scalar_max = max(scalar_max,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
end do
end do
block => block % next
@@ -378,8 +378,8 @@
implicit none
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(inout) :: grid
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(inout) :: grid
integer :: iEdge, iCell, k, cell1, cell2, iq
@@ -392,11 +392,11 @@
grid % qtot % array = 0.
grid % cqu % array = 1.
- if (num_scalars > 0) then
+ if (s % num_scalars > 0) then
do iCell = 1, nCells
do k = 1, nVertLevels
- do iq = moist_start, moist_end
+ do iq = s % moist_start, s % moist_end
grid % qtot % array(k,iCell) = grid % qtot % array(k,iCell) + s % scalars % array (iq, k, iCell)
end do
end do
@@ -430,8 +430,8 @@
implicit none
- type (grid_state), intent(inout) :: s
- type (grid_meta), intent(inout) :: grid
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(inout) :: grid
real (kind=RKIND), dimension(:,:,:), pointer :: scalar
real (kind=RKIND), dimension(:,:), pointer :: h, pressure, qtot, alpha, geopotential, theta
@@ -521,9 +521,9 @@
implicit none
- type (grid_state), intent(inout) :: tend
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, upstream_bias
@@ -1022,9 +1022,9 @@
implicit none
- type (grid_state), intent(in) :: tend
- type (grid_state), intent(inout) :: s
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(in) :: tend
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
real (kind=RKIND), intent(in) :: dt
integer, intent(in) :: small_step, number_small_steps
@@ -1275,13 +1275,13 @@
implicit none
- type (grid_state), intent(in) :: tend
- type (grid_state), intent(in) :: s_old
- type (grid_state), intent(out) :: s_new
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(in) :: tend
+ type (state_type), intent(in) :: s_old
+ type (state_type), intent(inout) :: s_new
+ type (mesh_type), intent(in) :: grid
real (kind=RKIND) :: dt
- integer :: i, iCell, iEdge, k, iScalar, cell1, cell2
+ integer :: i, iCell, iEdge, k, iScalar, cell1, cell2, num_scalars
real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
@@ -1290,12 +1290,14 @@
real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
integer, dimension(:,:), pointer :: cellsOnEdge
- real (kind=RKIND), dimension( num_scalars, grid % nVertLevels + 1 ) :: wdtn
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels + 1 ) :: wdtn
integer :: nVertLevels
real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
real (kind=RKIND) :: coef_3rd_order
+ num_scalars = s_old % num_scalars
+
coef_3rd_order = 0.
if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
@@ -1462,16 +1464,16 @@
implicit none
- type (grid_state), intent(in) :: tend
- type (grid_state), intent(in) :: s_old
- type (grid_state), intent(out) :: s_new
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(in) :: tend
+ 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 :: i, iCell, iEdge, k, iScalar, cell_upwind, cell1, cell2
+ 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
@@ -1481,10 +1483,10 @@
real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
integer, dimension(:,:), pointer :: cellsOnEdge
- real (kind=RKIND), dimension( num_scalars, grid % nEdges+1) :: h_flux
- real (kind=RKIND), dimension( num_scalars, grid % nCells+1, 2 ) :: v_flux, v_flux_upwind, s_update
- real (kind=RKIND), dimension( num_scalars, grid % nCells+1, 2 ) :: scale_out, scale_in
- real (kind=RKIND), dimension( num_scalars ) :: s_max, s_min, s_max_update, s_min_update
+ 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( s_old % num_scalars ) :: s_max, s_min, s_max_update, s_min_update
integer :: nVertLevels, km0, km1, ktmp, kcp1, kcm1
@@ -1492,6 +1494,8 @@
real (kind=RKIND), parameter :: eps=1.e-20
real (kind=RKIND) :: coef_3rd_order
+ num_scalars = s_old % num_scalars
+
scalar_old => s_old % scalars % array
scalar_new => s_new % scalars % array
deriv_two => grid % deriv_two % array
@@ -1794,8 +1798,8 @@
implicit none
real (kind=RKIND), intent(in) :: dt
- type (grid_state), intent(inout) :: s
- type (grid_meta), intent(in) :: grid
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
@@ -2045,9 +2049,9 @@
implicit none
- type (grid_state), intent(inout) :: s_new
- type (grid_state), intent(in) :: s_old
- type (grid_meta), intent(inout) :: grid
+ type (state_type), intent(inout) :: s_new
+ type (state_type), intent(in) :: s_old
+ type (mesh_type), intent(inout) :: grid
real (kind=RKIND), intent(in) :: dt
Modified: branches/swmodel_del4/src/core_hyd_atmos/mpas_interface.F
===================================================================
--- branches/swmodel_del4/src/core_hyd_atmos/mpas_interface.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_hyd_atmos/mpas_interface.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -12,6 +12,20 @@
end subroutine mpas_setup_test_case
+subroutine mpas_init_domain(domain)
+! Initialize grid variables that are computed from the netcdf input file.
+
+ use grid_types
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ ! This is currently a stub.
+
+end subroutine mpas_init_domain
+
+
subroutine mpas_init(block, mesh, dt)
use grid_types
@@ -23,16 +37,16 @@
implicit none
type (block_type), intent(inout) :: block
- type (grid_meta), intent(inout) :: mesh
+ type (mesh_type), intent(inout) :: mesh
real (kind=RKIND), intent(in) :: dt
- call compute_solver_constants(block % time_levs(1) % state, mesh)
- call compute_state_diagnostics(block % time_levs(1) % state, mesh)
- call compute_solve_diagnostics(dt, block % time_levs(1) % state, mesh)
+ call compute_solver_constants(block % state % time_levs(1) % state, mesh)
+ call compute_state_diagnostics(block % state % time_levs(1) % state, mesh)
+ call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
call initialize_advection_rk(mesh)
call rbfInterp_initialize(mesh)
call init_reconstruct(mesh)
- call reconstruct(block % time_levs(1) % state, mesh)
+ call reconstruct(block % state % time_levs(1) % state, mesh)
end subroutine mpas_init
Modified: branches/swmodel_del4/src/core_ocean/Makefile
===================================================================
--- branches/swmodel_del4/src/core_ocean/Makefile 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_ocean/Makefile 2010-10-22 19:14:07 UTC (rev 578)
@@ -1,6 +1,7 @@
.SUFFIXES: .F .o
OBJS = module_test_cases.o \
+ module_advection.o \
module_time_integration.o \
module_global_diagnostics.o \
mpas_interface.o
@@ -12,11 +13,13 @@
module_test_cases.o:
+module_advection.o:
+
module_time_integration.o:
module_global_diagnostics.o:
-mpas_interface.o: module_global_diagnostics.o module_test_cases.o module_time_integration.o
+mpas_interface.o: module_advection.o module_global_diagnostics.o module_test_cases.o module_time_integration.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/swmodel_del4/src/core_ocean/Registry
===================================================================
--- branches/swmodel_del4/src/core_ocean/Registry 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_ocean/Registry 2010-10-22 19:14:07 UTC (rev 578)
@@ -29,8 +29,11 @@
namelist real vmix config_vmixTanhDiffMin 1.0e-5
namelist real vmix config_vmixTanhZMid -100
namelist real vmix config_vmixTanhZWidth 100
-namelist character advection config_hor_tracer_adv 'centered'
-namelist character advection config_vert_tracer_adv 'centered'
+namelist character advection config_vert_tracer_adv 'centered'
+namelist integer advection config_tracer_adv_order 2
+namelist integer advection config_thickness_adv_order 2
+namelist logical advection config_positive_definite false
+namelist logical advection config_monotonic false
#
# dim type name_in_file name_in_code
@@ -42,128 +45,150 @@
dim nVertices nVertices
dim TWO 2
dim R3 3
+dim FIFTEEN 15
+dim TWENTYONE 21
dim vertexDegree vertexDegree
dim nVertLevels nVertLevels
dim nVertLevelsP1 nVertLevels+1
#
-# var type name_in_file ( dims ) iro- name_in_code super-array array_class
+# var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
#
-var real xtime ( Time ) ro xtime - -
+var persistent real xtime ( Time ) 2 ro xtime state - -
-var real latCell ( nCells ) iro latCell - -
-var real lonCell ( nCells ) iro lonCell - -
-var real xCell ( nCells ) iro xCell - -
-var real yCell ( nCells ) iro yCell - -
-var real zCell ( nCells ) iro zCell - -
-var integer indexToCellID ( nCells ) iro indexToCellID - -
+var persistent real latCell ( nCells ) 0 iro latCell mesh - -
+var persistent real lonCell ( nCells ) 0 iro lonCell mesh - -
+var persistent real xCell ( nCells ) 0 iro xCell mesh - -
+var persistent real yCell ( nCells ) 0 iro yCell mesh - -
+var persistent real zCell ( nCells ) 0 iro zCell mesh - -
+var persistent integer indexToCellID ( nCells ) 0 iro indexToCellID mesh - -
-var real latEdge ( nEdges ) iro latEdge - -
-var real lonEdge ( nEdges ) iro lonEdge - -
-var real xEdge ( nEdges ) iro xEdge - -
-var real yEdge ( nEdges ) iro yEdge - -
-var real zEdge ( nEdges ) iro zEdge - -
-var integer indexToEdgeID ( nEdges ) iro indexToEdgeID - -
+var persistent real latEdge ( nEdges ) 0 iro latEdge mesh - -
+var persistent real lonEdge ( nEdges ) 0 iro lonEdge mesh - -
+var persistent real xEdge ( nEdges ) 0 iro xEdge mesh - -
+var persistent real yEdge ( nEdges ) 0 iro yEdge mesh - -
+var persistent real zEdge ( nEdges ) 0 iro zEdge mesh - -
+var persistent integer indexToEdgeID ( nEdges ) 0 iro indexToEdgeID mesh - -
-var real latVertex ( nVertices ) iro latVertex - -
-var real lonVertex ( nVertices ) iro lonVertex - -
-var real xVertex ( nVertices ) iro xVertex - -
-var real yVertex ( nVertices ) iro yVertex - -
-var real zVertex ( nVertices ) iro zVertex - -
-var integer indexToVertexID ( nVertices ) iro indexToVertexID - -
+var persistent real latVertex ( nVertices ) 0 iro latVertex mesh - -
+var persistent real lonVertex ( nVertices ) 0 iro lonVertex mesh - -
+var persistent real xVertex ( nVertices ) 0 iro xVertex mesh - -
+var persistent real yVertex ( nVertices ) 0 iro yVertex mesh - -
+var persistent real zVertex ( nVertices ) 0 iro zVertex mesh - -
+var persistent integer indexToVertexID ( nVertices ) 0 iro indexToVertexID mesh - -
-var integer cellsOnEdge ( TWO nEdges ) iro cellsOnEdge - -
-var integer nEdgesOnCell ( nCells ) iro nEdgesOnCell - -
-var integer nEdgesOnEdge ( nEdges ) iro nEdgesOnEdge - -
-var integer edgesOnCell ( maxEdges nCells ) iro edgesOnCell - -
-var integer edgesOnEdge ( maxEdges2 nEdges ) iro edgesOnEdge - -
+var persistent integer cellsOnEdge ( TWO nEdges ) 0 iro cellsOnEdge mesh - -
+var persistent integer nEdgesOnCell ( nCells ) 0 iro nEdgesOnCell mesh - -
+var persistent integer nEdgesOnEdge ( nEdges ) 0 iro nEdgesOnEdge mesh - -
+var persistent integer edgesOnCell ( maxEdges nCells ) 0 iro edgesOnCell mesh - -
+var persistent integer edgesOnEdge ( maxEdges2 nEdges ) 0 iro edgesOnEdge mesh - -
-var real weightsOnEdge ( maxEdges2 nEdges ) iro weightsOnEdge - -
-var real dvEdge ( nEdges ) iro dvEdge - -
-var real dcEdge ( nEdges ) iro dcEdge - -
-var real angleEdge ( nEdges ) iro angleEdge - -
-var real areaCell ( nCells ) iro areaCell - -
-var real areaTriangle ( nVertices ) iro areaTriangle - -
+var persistent real weightsOnEdge ( maxEdges2 nEdges ) 0 iro weightsOnEdge mesh - -
+var persistent real dvEdge ( nEdges ) 0 iro dvEdge mesh - -
+var persistent real dcEdge ( nEdges ) 0 iro dcEdge mesh - -
+var persistent real angleEdge ( nEdges ) 0 iro angleEdge mesh - -
+var persistent real areaCell ( nCells ) 0 iro areaCell mesh - -
+var persistent real areaTriangle ( nVertices ) 0 iro areaTriangle mesh - -
-var real edgeNormalVectors ( R3 nEdges ) o edgeNormalVectors - -
-var real localVerticalUnitVectors ( R3 nCells ) o localVerticalUnitVectors - -
-var real cellTangentPlane ( R3 TWO nEdges ) o cellTangentPlane - -
+var persistent real edgeNormalVectors ( R3 nEdges ) 0 o edgeNormalVectors mesh - -
+var persistent real localVerticalUnitVectors ( R3 nCells ) 0 o localVerticalUnitVectors mesh - -
+var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 o cellTangentPlane mesh - -
-var integer cellsOnCell ( maxEdges nCells ) iro cellsOnCell - -
-var integer verticesOnCell ( maxEdges nCells ) iro verticesOnCell - -
-var integer verticesOnEdge ( TWO nEdges ) iro verticesOnEdge - -
-var integer edgesOnVertex ( vertexDegree nVertices ) iro edgesOnVertex - -
-var integer cellsOnVertex ( vertexDegree nVertices ) iro cellsOnVertex - -
-var real kiteAreasOnVertex ( vertexDegree nVertices ) iro kiteAreasOnVertex - -
-var real fEdge ( nEdges ) iro fEdge - -
-var real fVertex ( nVertices ) iro fVertex - -
-var real h_s ( nCells ) iro h_s - -
+var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
+var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
+var persistent integer verticesOnEdge ( TWO nEdges ) 0 iro verticesOnEdge mesh - -
+var persistent integer edgesOnVertex ( vertexDegree nVertices ) 0 iro edgesOnVertex mesh - -
+var persistent integer cellsOnVertex ( vertexDegree nVertices ) 0 iro cellsOnVertex mesh - -
+var persistent real kiteAreasOnVertex ( vertexDegree nVertices ) 0 iro kiteAreasOnVertex mesh - -
+var persistent real fEdge ( nEdges ) 0 iro fEdge mesh - -
+var persistent real fVertex ( nVertices ) 0 iro fVertex mesh - -
+var persistent real h_s ( nCells ) 0 iro h_s mesh - -
+# Space needed for advection
+var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 o deriv_two mesh - -
+var persistent integer advCells ( TWENTYONE nCells ) 0 - advCells mesh - -
+
+# !! NOTE: the following arrays are needed to allow the use
+# !! of the module_advection.F w/o alteration
+# Space needed for deformation calculation weights
+var persistent real defc_a ( maxEdges nCells ) 0 - defc_a mesh - -
+var persistent real defc_b ( maxEdges nCells ) 0 - defc_b mesh - -
+var persistent real kdiff ( nVertLevels nCells Time ) 0 - kdiff mesh - -
+
# Arrays required for reconstruction of velocity field
-var real coeffs_reconstruct ( R3 maxEdges nCells ) - coeffs_reconstruct - -
+var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 - coeffs_reconstruct mesh - -
# Arrays for z-level version of mpas-ocean
-var integer maxLevelsCell ( nCells ) iro kmaxCell - -
-var integer maxLevelsEdge ( nEdges ) iro kmaxEdge - -
-var real hZLevel ( nVertLevels ) iro hZLevel - -
-var real zMidZLevel ( nVertLevels ) iro zMidZLevel - -
-var real zTopZLevel ( nVertLevelsP1 ) iro zTopZLevel - -
+var persistent integer maxLevelsCell ( nCells ) 0 iro kmaxCell mesh - -
+var persistent integer maxLevelsEdge ( nEdges ) 0 iro kmaxEdge mesh - -
+var persistent real hZLevel ( nVertLevels ) 0 iro hZLevel mesh - -
+var persistent real zMidZLevel ( nVertLevels ) 0 iro zMidZLevel mesh - -
+var persistent real zTopZLevel ( nVertLevelsP1 ) 0 iro zTopZLevel mesh - -
# Boundary conditions: read from input, saved in restart and written to output
-var integer boundaryEdge ( nVertLevels nEdges ) iro boundaryEdge - -
-var integer boundaryVertex ( nVertLevels nVertices ) iro boundaryVertex - -
-var real u_src ( nVertLevels nEdges ) iro u_src - -
+var persistent integer boundaryEdge ( nVertLevels nEdges ) 0 iro boundaryEdge mesh - -
+var persistent integer boundaryVertex ( nVertLevels nVertices ) 0 iro boundaryVertex mesh - -
+var persistent integer boundaryCell ( nVertLevels nCells ) 0 iro boundaryCell mesh - -
+var persistent real u_src ( nVertLevels nEdges ) 0 iro u_src mesh - -
# Prognostic variables: read from input, saved in restart, and written to output
-var real u ( nVertLevels nEdges Time ) iro u - -
-var real h ( nVertLevels nCells Time ) iro h - -
-var real rho ( nVertLevels nCells Time ) iro rho - -
-var real temperature ( nVertLevels nCells Time ) iro temperature tracers dynamics
-var real salinity ( nVertLevels nCells Time ) iro salinity tracers dynamics
-var real tracer1 ( nVertLevels nCells Time ) iro tracer1 tracers testing
-var real tracer2 ( nVertLevels nCells Time ) iro tracer2 tracers testing
+var persistent real u ( nVertLevels nEdges Time ) 2 iro u state - -
+var persistent real h ( nVertLevels nCells Time ) 2 iro h state - -
+var persistent real rho ( nVertLevels nCells Time ) 2 iro rho state - -
+var persistent real temperature ( nVertLevels nCells Time ) 2 iro temperature state tracers dynamics
+var persistent real salinity ( nVertLevels nCells Time ) 2 iro salinity state tracers dynamics
+var persistent real tracer1 ( nVertLevels nCells Time ) 2 iro tracer1 state tracers testing
+var persistent real tracer2 ( nVertLevels nCells Time ) 2 iro tracer2 state tracers testing
+# Tendency variables: neither read nor written to any files
+var persistent real tend_u ( nVertLevels nEdges Time ) 1 - u tend - -
+var persistent real tend_h ( nVertLevels nCells Time ) 1 - h tend - -
+var persistent real tend_temperature ( nVertLevels nCells Time ) 1 - temperature tend tracers dynamics
+var persistent real tend_salinity ( nVertLevels nCells Time ) 1 - salinity tend tracers dynamics
+var persistent real tend_tracer1 ( nVertLevels nCells Time ) 1 - tracer1 tend tracers testing
+var persistent real tend_tracer2 ( nVertLevels nCells Time ) 1 - tracer2 tend tracers testing
+
# Diagnostic fields: only written to output
-var real v ( nVertLevels nEdges Time ) o v - -
-var real divergence ( nVertLevels nCells Time ) o divergence - -
-var real vorticity ( nVertLevels nVertices Time ) o vorticity - -
-var real pv_edge ( nVertLevels nEdges Time ) o pv_edge - -
-var real h_edge ( nVertLevels nEdges Time ) o h_edge - -
-var real h_vertex ( nVertLevels nVertices Time ) o h_vertex - -
-var real ke ( nVertLevels nCells Time ) o ke - -
-var real ke_edge ( nVertLevels nEdges Time ) o ke_edge - -
-var real pv_vertex ( nVertLevels nVertices Time ) o pv_vertex - -
-var real pv_cell ( nVertLevels nCells Time ) o pv_cell - -
-var real uReconstructX ( nVertLevels nCells Time ) o uReconstructX - -
-var real uReconstructY ( nVertLevels nCells Time ) o uReconstructY - -
-var real uReconstructZ ( nVertLevels nCells Time ) o uReconstructZ - -
-var real uReconstructZonal ( nVertLevels nCells Time ) o uReconstructZonal - -
-var real uReconstructMeridional ( nVertLevels nCells Time ) o uReconstructMeridional - -
-var real zMid ( nVertLevels nCells Time ) o zMid - -
-var real zTop ( nVertLevelsP1 nCells Time ) o zTop - -
-var real zMidEdge ( nVertLevels nEdges Time ) o zMidEdge - -
-var real zTopEdge ( nVertLevelsP1 nEdges Time ) o zTopEdge - -
-var real p ( nVertLevels nCells Time ) o p - -
-var real pTop ( nVertLevelsP1 nCells Time ) o pTop - -
-var real pZLevel ( nVertLevels nCells Time ) o pZLevel - -
-var real MontPot ( nVertLevels nCells Time ) o MontPot - -
-var real wTop ( nVertLevelsP1 nCells Time ) o wTop - -
-var real ssh ( nCells Time ) o ssh - -
+var persistent real v ( nVertLevels nEdges Time ) 2 o v state - -
+var persistent real divergence ( nVertLevels nCells Time ) 2 o divergence state - -
+var persistent real vorticity ( nVertLevels nVertices Time ) 2 o vorticity state - -
+var persistent real pv_edge ( nVertLevels nEdges Time ) 2 o pv_edge state - -
+var persistent real h_edge ( nVertLevels nEdges Time ) 2 o h_edge state - -
+var persistent real h_vertex ( nVertLevels nVertices Time ) 2 o h_vertex state - -
+var persistent real ke ( nVertLevels nCells Time ) 2 o ke state - -
+var persistent real ke_edge ( nVertLevels nEdges Time ) 2 o ke_edge state - -
+var persistent real pv_vertex ( nVertLevels nVertices Time ) 2 o pv_vertex state - -
+var persistent real pv_cell ( nVertLevels nCells Time ) 2 o pv_cell state - -
+var persistent real uReconstructX ( nVertLevels nCells Time ) 2 o uReconstructX state - -
+var persistent real uReconstructY ( nVertLevels nCells Time ) 2 o uReconstructY state - -
+var persistent real uReconstructZ ( nVertLevels nCells Time ) 2 o uReconstructZ state - -
+var persistent real uReconstructZonal ( nVertLevels nCells Time ) 2 o uReconstructZonal state - -
+var persistent real uReconstructMeridional ( nVertLevels nCells Time ) 2 o uReconstructMeridional state - -
+var persistent real zMid ( nVertLevels nCells Time ) 2 o zMid state - -
+var persistent real zTop ( nVertLevelsP1 nCells Time ) 2 o zTop state - -
+var persistent real zMidEdge ( nVertLevels nEdges Time ) 2 o zMidEdge state - -
+var persistent real zTopEdge ( nVertLevelsP1 nEdges Time ) 2 o zTopEdge state - -
+var persistent real p ( nVertLevels nCells Time ) 2 o p state - -
+var persistent real pTop ( nVertLevelsP1 nCells Time ) 2 o pTop state - -
+var persistent real pZLevel ( nVertLevels nCells Time ) 2 o pZLevel state - -
+var persistent real MontPot ( nVertLevels nCells Time ) 2 o MontPot state - -
+var persistent real wTop ( nVertLevelsP1 nCells Time ) 2 o wTop state - -
+var persistent real ssh ( nCells Time ) 2 o ssh state - -
# Other diagnostic variables: neither read nor written to any files
-var real vh ( nVertLevels nEdges Time ) - vh - -
-var real circulation ( nVertLevels nVertices Time ) - circulation - -
-var real gradPVt ( nVertLevels nEdges Time ) - gradPVt - -
-var real gradPVn ( nVertLevels nEdges Time ) - gradPVn - -
+var persistent real vh ( nVertLevels nEdges Time ) 2 - vh state - -
+var persistent real circulation ( nVertLevels nVertices Time ) 2 - circulation state - -
+var persistent real gradPVt ( nVertLevels nEdges Time ) 2 - gradPVt state - -
+var persistent real gradPVn ( nVertLevels nEdges Time ) 2 - gradPVn state - -
# xsad 10-02-05:
# Globally reduced diagnostic variables: only written to output
-var real areaCellGlobal ( Time ) o areaCellGlobal - -
-var real areaEdgeGlobal ( Time ) o areaEdgeGlobal - -
-var real areaTriangleGlobal ( Time ) o areaTriangleGlobal - -
+var persistent real areaCellGlobal ( Time ) 2 o areaCellGlobal state - -
+var persistent real areaEdgeGlobal ( Time ) 2 o areaEdgeGlobal state - -
+var persistent real areaTriangleGlobal ( Time ) 2 o areaTriangleGlobal state - -
-var real volumeCellGlobal ( Time ) o volumeCellGlobal - -
-var real volumeEdgeGlobal ( Time ) o volumeEdgeGlobal - -
-var real CFLNumberGlobal ( Time ) o CFLNumberGlobal - -
+var persistent real volumeCellGlobal ( Time ) 2 o volumeCellGlobal state - -
+var persistent real volumeEdgeGlobal ( Time ) 2 o volumeEdgeGlobal state - -
+var persistent real CFLNumberGlobal ( Time ) 2 o CFLNumberGlobal state - -
# xsad 10-02-05 end
Modified: branches/swmodel_del4/src/core_ocean/module_global_diagnostics.F
===================================================================
--- branches/swmodel_del4/src/core_ocean/module_global_diagnostics.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_ocean/module_global_diagnostics.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -27,8 +27,8 @@
implicit none
type (dm_info), intent(in) :: dminfo
- type (grid_state), intent(inout) :: state
- type (grid_meta), intent(in) :: grid
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
integer, intent(in) :: timeIndex
real (kind=RKIND), intent(in) :: dt
@@ -43,7 +43,7 @@
real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal
real (kind=RKIND) :: localCFL, localSum
integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins
- integer :: timeLevel,k,i
+ integer :: timeLevel,k,i, num_tracers
integer, parameter :: kMaxVariables = 1024 ! this must be a little more than double the number of variables to be reduced
@@ -51,6 +51,8 @@
integer :: fileID
+ num_tracers = state % num_tracers
+
nVertLevels = grid % nVertLevels
nCellsSolve = grid % nCellsSolve
nEdgesSolve = grid % nEdgesSolve
Modified: branches/swmodel_del4/src/core_ocean/module_test_cases.F
===================================================================
--- branches/swmodel_del4/src/core_ocean/module_test_cases.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_ocean/module_test_cases.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -25,15 +25,14 @@
type (block_type), pointer :: block_ptr
type (dm_info) :: dminfo
- ! mrp 100507: for diagnostic output
integer :: iTracer
real (kind=RKIND), dimension(:), pointer :: xCell,yCell, &
hZLevel, zMidZLevel, zTopZLevel, latCell,LonCell
real (kind=RKIND), dimension(:,:), pointer :: h, u, u_src, rho
real (kind=RKIND), dimension(:,:,:), pointer :: tracers
real (kind=RKIND) :: delta_rho, pi, latCenter, lonCenter, dist
+ real (kind=RKIND) :: centerx, centery
integer :: nCells, nEdges, nVertices, nVertLevels
- ! mrp 100507 end: for diagnostic output
if (config_test_case == 0) then
write(0,*) 'Using initial conditions supplied in input file'
@@ -44,7 +43,7 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call sw_test_case_1(block_ptr % mesh, block_ptr % time_levs(1) % state)
+ call sw_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
block_ptr => block_ptr % next
end do
@@ -54,7 +53,7 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call sw_test_case_2(block_ptr % mesh, block_ptr % time_levs(1) % state)
+ call sw_test_case_2(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
block_ptr => block_ptr % next
end do
@@ -64,7 +63,7 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call sw_test_case_5(block_ptr % mesh, block_ptr % time_levs(1) % state)
+ call sw_test_case_5(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
block_ptr => block_ptr % next
end do
@@ -74,7 +73,7 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call sw_test_case_6(block_ptr % mesh, block_ptr % time_levs(1) % state)
+ call sw_test_case_6(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
block_ptr => block_ptr % next
end do
@@ -89,8 +88,8 @@
do while (associated(block_ptr))
do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, &
- block_ptr % time_levs(i) % state)
+ call copy_state(block_ptr % state % time_levs(i) % state, &
+ block_ptr % state % time_levs(1) % state)
end do
block_ptr => block_ptr % next
@@ -99,10 +98,10 @@
! Initialize z-level grid variables from h, read in from input file.
block_ptr => domain % blocklist
do while (associated(block_ptr))
- h => block_ptr % time_levs(1) % state % h % array
- u => block_ptr % time_levs(1) % state % u % array
- rho => block_ptr % time_levs(1) % state % rho % array
- tracers => block_ptr % time_levs(1) % state % tracers % array
+ h => block_ptr % state % time_levs(1) % state % h % array
+ u => block_ptr % state % time_levs(1) % state % u % array
+ rho => block_ptr % state % time_levs(1) % state % rho % array
+ tracers => block_ptr % state % time_levs(1) % state % tracers % array
u_src => block_ptr % mesh % u_src % array
xCell => block_ptr % mesh % xCell % array
yCell => block_ptr % mesh % yCell % array
@@ -146,31 +145,39 @@
! Set tracers, if not done in grid.nc file
!tracers = 0.0
+ centerx = 1.0e6
+ centery = 1.0e6
+ dist = 2.0e5
do iCell = 1,nCells
dist = sqrt( (latCell(iCell)-latCenter)**2 + (lonCell(iCell)-lonCenter)**2)
do iLevel = 1,nVertLevels
! for 20 layer test
- ! tracers(index_temperature,iLevel,iCell) = 5.0 ! temperature
- ! tracers(index_salinity,iLevel,iCell) = 1.4 + iLevel*0.6 ! salinity
+ ! tracers(block_ptr % state % time_levs(1) % state % index_temperature,iLevel,iCell) = 5.0 ! temperature
+ ! tracers(block_ptr % state % time_levs(1) % state % index_salinity,iLevel,iCell) = 1.4 + iLevel*0.6 ! salinity
! for x3, 25 layer test
- !tracers(index_temperature,iLevel,iCell) = 10.0 ! temperature
- !tracers(index_salinity,iLevel,iCell) = 1.4 + iLevel*0.6 ! salinity
+ !tracers(block_ptr % state % time_levs(1) % state % index_temperature,iLevel,iCell) = 10.0 ! temperature
+ !tracers(block_ptr % state % time_levs(1) % state % index_salinity,iLevel,iCell) = 1.4 + iLevel*0.6 ! salinity
- ! tracers(index_tracer1,iLevel,iCell) = 1.0
- ! tracers(index_tracer2,iLevel,iCell) = &
+ ! tracers(block_ptr % state % time_levs(1) % state % index_tracer1,iLevel,iCell) = 1.0
+ ! tracers(block_ptr % state % time_levs(1) % state % index_tracer2,iLevel,iCell) = &
! (yCell(iCell)/4000.e3 + xCell(iCell)/2500.e3 )/2.0
- ! Tracer blob
- !if (dist.lt.pi/16) then
- ! tracers(index_tracer1,iLevel,iCell) = 1.0
- !!else
- ! tracers(index_tracer1,iLevel,iCell) = 0.0
+ !tracers(block_ptr % state % time_levs(1) % state % index_tracer1,iLevel,iCell) = block_ptr % mesh % lonCell % array(iCell)
+ !tracers(block_ptr % state % time_levs(1) % state % index_tracer2,iLevel,iCell) = block_ptr % mesh % latCell % array(iCell)
+
+ ! place tracer blob with radius dist at (centerx,centery)
+ !if ( sqrt( (xCell(iCell)-centerx)**2 &
+ ! + (yCell(iCell)-centery)**2) &
+ ! .lt.dist) then
+ ! tracers(block_ptr % state % time_levs(1) % state % index_tracer1,iLevel,iCell) = 1.0
+ !else
+ ! tracers(block_ptr % state % time_levs(1) % state % index_tracer1,iLevel,iCell) = 0.0
!endif
rho(iLevel,iCell) = 1000.0*( 1.0 &
- - 2.5e-4*tracers(index_temperature,iLevel,iCell) &
- + 7.6e-4*tracers(index_salinity,iLevel,iCell))
+ - 2.5e-4*tracers(block_ptr % state % time_levs(1) % state % index_temperature,iLevel,iCell) &
+ + 7.6e-4*tracers(block_ptr % state % time_levs(1) % state % index_salinity,iLevel,iCell))
enddo
enddo
@@ -194,7 +201,7 @@
enddo
print '(10a)', 'itracer ilevel min tracer max tracer'
- do iTracer=1,num_tracers
+ do iTracer=1,block_ptr % state % time_levs(1) % state % num_tracers
do iLevel = 1,nVertLevels
print '(2i5,20es12.4)', iTracer,ilevel, &
minval(tracers(itracer,iLevel,1:nCells)), maxval(tracers(itracer,iLevel,1:nCells))
@@ -219,8 +226,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
real (kind=RKIND), parameter :: h0 = 1000.0
@@ -295,8 +302,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
real (kind=RKIND), parameter :: gh0 = 29400.0
@@ -386,8 +393,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
real (kind=RKIND), parameter :: u0 = 20.
real (kind=RKIND), parameter :: gh0 = 5960.0*gravity
@@ -508,8 +515,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
real (kind=RKIND), parameter :: h0 = 8000.0
real (kind=RKIND), parameter :: w = 7.848e-6
Modified: branches/swmodel_del4/src/core_ocean/module_time_integration.F
===================================================================
--- branches/swmodel_del4/src/core_ocean/module_time_integration.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_ocean/module_time_integration.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -37,10 +37,10 @@
block => domain % blocklist
do while (associated(block))
- block % time_levs(2) % state % xtime % scalar &
- = block % time_levs(1) % state % xtime % scalar + dt
+ block % state % time_levs(2) % state % xtime % scalar &
+ = block % state % time_levs(1) % state % xtime % scalar + dt
- if (isNaN(sum(block % time_levs(2) % state % u % array))) then
+ if (isNaN(sum(block % state % time_levs(2) % state % u % array))) then
write(0,*) 'Abort: NaN detected'
call dmpar_abort(dminfo)
endif
@@ -69,13 +69,16 @@
integer :: iCell, k, i
type (block_type), pointer :: block
+ type (state_type) :: provis
- integer, parameter :: PROVIS = 1
- integer, parameter :: TEND = 2
integer :: rk_step
real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights
+ block => domain % blocklist
+ call allocate_state(provis, &
+ block % mesh % nCells, block % mesh % nEdges, block % mesh % maxEdges, block % mesh % maxEdges2, &
+ block % mesh % nVertices, block % mesh % vertexDegree, block % mesh % nVertLevels )
!
! Initialize time_levs(2) with state at current time
@@ -86,16 +89,16 @@
block => domain % blocklist
do while (associated(block))
- block % time_levs(2) % state % u % array(:,:) = block % time_levs(1) % state % u % array(:,:)
- block % time_levs(2) % state % h % array(:,:) = block % time_levs(1) % state % h % array(:,:)
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
do iCell=1,block % mesh % nCells ! couple tracers to h
do k=1,block % mesh % nVertLevels
- block % time_levs(2) % state % tracers % array(:,k,iCell) = block % time_levs(1) % state % tracers % array(:,k,iCell) &
- * block % time_levs(1) % state % h % array(k,iCell)
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ * block % state % time_levs(1) % state % h % array(k,iCell)
end do
end do
- call copy_state(block % time_levs(1) % state, block % intermediate_step(PROVIS))
+ call copy_state(provis, block % state % time_levs(1) % state)
block => block % next
end do
@@ -119,15 +122,15 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(PROVIS) % pv_edge % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, provis % 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 dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % divergence % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % vorticity % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
block % mesh % nVertLevels, block % mesh % nVertices, &
block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
end if
@@ -139,9 +142,9 @@
block => domain % blocklist
do while (associated(block))
- call compute_tend(block % intermediate_step(TEND), block % intermediate_step(PROVIS), block % mesh)
- call compute_scalar_tend(block % intermediate_step(TEND), block % intermediate_step(PROVIS), block % mesh)
- call enforce_boundaryEdge(block % intermediate_step(TEND), block % mesh)
+ call compute_tend(block % tend, provis, block % mesh)
+ call compute_scalar_tend(block % tend, provis, block % mesh)
+ call enforce_boundaryEdge(block % tend, block % mesh)
block => block % next
end do
@@ -149,14 +152,14 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(TEND) % u % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % u % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(TEND) % h % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % h % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % intermediate_step(TEND) % tracers % array(:,:,:), &
- num_tracers, block % mesh % nVertLevels, block % mesh % nCells, &
+ call dmpar_exch_halo_field3dReal(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
@@ -167,24 +170,24 @@
block => domain % blocklist
do while (associated(block))
- block % intermediate_step(PROVIS) % u % array(:,:) = block % time_levs(1) % state % u % array(:,:) &
- + rk_substep_weights(rk_step) * block % intermediate_step(TEND) % u % array(:,:)
- block % intermediate_step(PROVIS) % h % array(:,:) = block % time_levs(1) % state % h % array(:,:) &
- + rk_substep_weights(rk_step) * block % intermediate_step(TEND) % h % array(:,:)
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) &
+ + rk_substep_weights(rk_step) * block % tend % u % array(:,:)
+ provis % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:) &
+ + rk_substep_weights(rk_step) * block % tend % h % array(:,:)
do iCell=1,block % mesh % nCells
do k=1,block % mesh % nVertLevels
- block % intermediate_step(PROVIS) % tracers % array(:,k,iCell) = ( &
- block % time_levs(1) % state % h % array(k,iCell) * &
- block % time_levs(1) % state % tracers % array(:,k,iCell) &
- + rk_substep_weights(rk_step) * block % intermediate_step(TEND) % tracers % array(:,k,iCell) &
- ) / block % intermediate_step(PROVIS) % h % array(k,iCell)
+ provis % tracers % array(:,k,iCell) = ( &
+ block % state % time_levs(1) % state % h % array(k,iCell) * &
+ block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ + rk_substep_weights(rk_step) * block % tend % tracers % array(:,k,iCell) &
+ ) / provis % h % array(k,iCell)
end do
end do
if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % intermediate_step(PROVIS) % u % array(:,:) = block % time_levs(1) % state % u % array(:,:)
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
- call compute_solve_diagnostics(dt, block % intermediate_step(PROVIS), block % mesh)
+ call compute_solve_diagnostics(dt, provis, block % mesh)
block => block % next
end do
end if
@@ -195,16 +198,16 @@
block => domain % blocklist
do while (associated(block))
- block % time_levs(2) % state % u % array(:,:) = block % time_levs(2) % state % u % array(:,:) &
- + rk_weights(rk_step) * block % intermediate_step(TEND) % u % array(:,:)
- block % time_levs(2) % state % h % array(:,:) = block % time_levs(2) % state % h % array(:,:) &
- + rk_weights(rk_step) * block % intermediate_step(TEND) % h % array(:,:)
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % u % array(:,:) &
+ + rk_weights(rk_step) * block % tend % u % array(:,:)
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(2) % state % h % array(:,:) &
+ + rk_weights(rk_step) * block % tend % h % array(:,:)
do iCell=1,block % mesh % nCells
do k=1,block % mesh % nVertLevels
- block % time_levs(2) % state % tracers % array(:,k,iCell) = &
- block % time_levs(2) % state % tracers % array(:,k,iCell) &
- + rk_weights(rk_step) * block % intermediate_step(TEND) % tracers % array(:,k,iCell)
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ + rk_weights(rk_step) * block % tend % tracers % array(:,k,iCell)
end do
end do
@@ -223,23 +226,25 @@
do while (associated(block))
do iCell=1,block % mesh % nCells
do k=1,block % mesh % nVertLevels
- block % time_levs(2) % state % tracers % array(:,k,iCell) = &
- block % time_levs(2) % state % tracers % array(:,k,iCell) &
- / block % time_levs(2) % state % h % array(k,iCell)
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ / block % state % time_levs(2) % state % h % array(k,iCell)
end do
end do
if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % time_levs(2) % state % u % array(:,:) = block % time_levs(1) % state % u % array(:,:)
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
- call compute_solve_diagnostics(dt, block % time_levs(2) % state, block % mesh)
+ call compute_solve_diagnostics(dt, block % state % time_levs(2) % state, block % mesh)
- call reconstruct(block % time_levs(2) % state, block % mesh)
+ call reconstruct(block % state % time_levs(2) % state, block % mesh)
block => block % next
end do
+ call deallocate_state(provis)
+
end subroutine rk4
@@ -255,9 +260,9 @@
implicit none
- type (grid_state), intent(inout) :: tend
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
@@ -670,15 +675,14 @@
implicit none
- type (grid_state), intent(inout) :: tend
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
- integer :: iCell, iEdge, k, iTracer, cell1, cell2, upwindCell,&
- nEdges, nCells, nVertLevels
- real (kind=RKIND) :: h_tracer_eddy_diff2, h_tracer_eddy_diff4, invAreaCell1, invAreaCell2, tracer_turb_flux
- real (kind=RKIND) :: flux, tracer_edge, r
- real (kind=RKIND) :: dist
+ integer :: i, k, iCell, iEdge, iTracer, cell1, cell2, upwindCell,&
+ nEdges, nCells, nVertLevels, num_tracers
+ real (kind=RKIND) :: invAreaCell1, invAreaCell2, tracer_turb_flux
+ real (kind=RKIND) :: flux, tracer_edge, r, dist
real (kind=RKIND), dimension(:), pointer :: &
h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
real (kind=RKIND), dimension(:,:), pointer :: &
@@ -689,16 +693,21 @@
type (dm_info) :: dminfo
integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
- integer, dimension(:,:), pointer :: cellsOnEdge
- real (kind=RKIND), dimension(:), pointer :: &
- zTopZLevel
+ integer, dimension(:,:), pointer :: cellsOnEdge, boundaryCell
+ real (kind=RKIND), dimension(:), pointer :: zTopZLevel
real (kind=RKIND), dimension(:,:), allocatable:: fluxVertTop, tracerTop, boundaryMask
real (kind=RKIND), dimension(:,:,:), allocatable::tr_flux, tr_div, delsq_tracer
real (kind=RKIND), dimension(:), allocatable:: vertDiffTop
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND) :: coef_3rd_order
+
+
u => s % u % array
h => s % h % array
+ boundaryCell=> grid % boundaryCell % array
wTop => s % wTop % array
tracers => s % tracers % array
h_edge => s % h_edge % array
@@ -717,65 +726,148 @@
nEdges = grid % nEdges
nCells = grid % nCells
nVertLevels = grid % nVertLevels
+ num_tracers = s % num_tracers
+ deriv_two => grid % deriv_two % array
- h_tracer_eddy_diff2 = config_h_tracer_eddy_diff2
- h_tracer_eddy_diff4 = config_h_tracer_eddy_diff4
+ !
+ ! initialize tracer tendency (RHS of tracer equation) to zero.
+ !
+ tend_tr(:,:,:) = 0.0
!
! tracer tendency: horizontal advection term -div( h \phi u)
!
- tend_tr(:,:,:) = 0.0
- if (config_hor_tracer_adv.eq.'centered') then
+ coef_3rd_order = 0.
+ if (config_tracer_adv_order == 3) coef_3rd_order = 1.0
+ if (config_tracer_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCells .and. cell2 <= nCells) then
- do k=1,nVertLevels
- do iTracer=1,num_tracers
- tracer_edge = 0.5 * ( tracers(iTracer,k,cell1) &
- + tracers(iTracer,k,cell2))
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) &
- * tracer_edge
- tend_tr(iTracer,k,cell1) = tend_tr(iTracer,k,cell1) - flux
- tend_tr(iTracer,k,cell2) = tend_tr(iTracer,k,cell2) + flux
- end do
- end do
- end if
- end do
+ if (config_tracer_adv_order == 2) then
- elseif (config_hor_tracer_adv.eq.'upwind') then
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+ do k=1,nVertLevels
+ do iTracer=1,num_tracers
+ tracer_edge = 0.5 * (tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2))
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) * tracer_edge
+ tend_tr(iTracer,k,cell1) = tend_tr(iTracer,k,cell1) - flux/areaCell(cell1)
+ tend_tr(iTracer,k,cell2) = tend_tr(iTracer,k,cell2) + flux/areaCell(cell2)
+ end do
+ end do
+ end if
+ end do
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCells .and. cell2 <= nCells) then
- do k=1,nVertLevels
- if (u(k,iEdge)>0.0) then
- upwindCell = cell1
- else
- upwindCell = cell2
- endif
- do iTracer=1,num_tracers
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) &
- * tracers(iTracer,k,upwindCell)
- tend_tr(iTracer,k,cell1) = tend_tr(iTracer,k,cell1) - flux
- tend_tr(iTracer,k,cell2) = tend_tr(iTracer,k,cell2) + flux
- end do
- end do
- end if
- end do
+ else if (config_tracer_adv_order == 3) then
- endif
- do iCell=1,grid % nCellsSolve
- do k=1,grid % nVertLevelsSolve
- do iTracer=1,num_tracers
- tend_tr(iTracer,k,iCell) = tend_tr(iTracer,k,iCell) / areaCell(iCell)
- end do
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ do iTracer=1,num_tracers
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ !-- if u > 0:
+ if (u(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ !-- else u <= 0:
+ else
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ end if
+
+ !-- update tendency
+ tend_tr(iTracer,k,cell1) = tend_tr(iTracer,k,cell1) - flux/areaCell(cell1)
+ tend_tr(iTracer,k,cell2) = tend_tr(iTracer,k,cell2) + flux/areaCell(cell2)
+ enddo
+ end do
+ end if
end do
- end do
+ else if (config_tracer_adv_order == 4) then
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if an edge is not on the outer-most ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ do iTracer=1,num_tracers
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
+
+ !-- update tendency
+ tend_tr(iTracer,k,cell1) = tend_tr(iTracer,k,cell1) - flux/areaCell(cell1)
+ tend_tr(iTracer,k,cell2) = tend_tr(iTracer,k,cell2) + flux/areaCell(cell2)
+ enddo
+ end do
+ end if
+ end do
+
+ endif ! if (config_tracer_adv_order == 2 )
+
+
!
! tracer tendency: vertical advection term -d/dz( h \phi w)
!
@@ -820,7 +912,7 @@
!
! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 </font>
<font color="gray">abla \phi)
!
- if ( h_tracer_eddy_diff2 > 0.0 ) then
+ if ( config_h_tracer_eddy_diff2 > 0.0 ) then
!
! compute a boundary mask to enforce insulating boundary conditions in the horizontal
@@ -838,7 +930,7 @@
do k=1,grid % nVertLevels
do iTracer=1,num_tracers
! \kappa_2 </font>
<font color="gray">abla \phi on edge
- tracer_turb_flux = h_tracer_eddy_diff2 &
+ tracer_turb_flux = config_h_tracer_eddy_diff2 &
*( tracers(iTracer,k,cell2) &
- tracers(iTracer,k,cell1))/dcEdge(iEdge)
@@ -860,7 +952,7 @@
! tracer tendency: del4 horizontal tracer diffusion, &
! div(h \kappa_4 </font>
<font color="black">abla [div(h </font>
<font color="gray">abla \phi)])
!
- if ( h_tracer_eddy_diff4 > 0.0 ) then
+ if ( config_h_tracer_eddy_diff4 > 0.0 ) then
!
! compute a boundary mask to enforce insulating boundary conditions in the horizontal
@@ -911,7 +1003,7 @@
do k=1,grid % nVertLevels
do iTracer=1,num_tracers
- tracer_turb_flux = h_tracer_eddy_diff4 &
+ tracer_turb_flux = config_h_tracer_eddy_diff4 &
*( delsq_tracer(iTracer,k,cell2) &
- delsq_tracer(iTracer,k,cell1))/dcEdge(iEdge)
flux = dvEdge (iEdge) * tracer_turb_flux
@@ -1005,8 +1097,8 @@
implicit none
real (kind=RKIND), intent(in) :: dt
- type (grid_state), intent(inout) :: s
- type (grid_meta), intent(in) :: grid
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
@@ -1027,8 +1119,11 @@
real (kind=RKIND), dimension(:,:), allocatable:: div_u
character :: c1*6
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge, boundaryCell
integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND) :: coef_3rd_order
real (kind=RKIND) :: r, h1, h2
@@ -1077,6 +1172,7 @@
fVertex => grid % fVertex % array
fEdge => grid % fEdge % array
hZLevel => grid % hZLevel % array
+ deriv_two => grid % deriv_two % array
nCells = grid % nCells
nEdges = grid % nEdges
@@ -1084,30 +1180,142 @@
nVertLevels = grid % nVertLevels
boundaryEdge => grid % boundaryEdge % array
+ boundaryCell => grid % boundaryCell % array
!
- ! Compute height on cell edges at velocity locations
+ ! Find those cells that have an edge on the boundary
!
+ boundaryCell(:,:) = 0
do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCells .and. cell2 <= nCells) then
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- elseif(cell1 <= nCells) then
- do k=1,nVertLevels
- h_edge(k,iEdge) = h(k,cell1)
- end do
- elseif(cell2 <= nCells) then
- do k=1,nVertLevels
- h_edge(k,iEdge) = h(k,cell2)
- end do
- end if
- end do
+ do k=1,nVertLevels
+ if(boundaryEdge(k,iEdge).eq.1) then
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ boundaryCell(k,cell1) = 1
+ boundaryCell(k,cell2) = 1
+ endif
+ enddo
+ enddo
!
+ ! Compute height on cell edges at velocity locations
+ ! Namelist options control the order of accuracy of the reconstructed h_edge value
+ !
+
+ coef_3rd_order = 0.
+ if (config_thickness_adv_order == 3) coef_3rd_order = 1.0
+ if (config_thickness_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+ if (config_thickness_adv_order == 2) then
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+ do k=1,grid % nVertLevels
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
+ end if
+ end do
+
+ else if (config_thickness_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ !-- if u > 0:
+ if (u(k,iEdge) > 0) then
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ !-- else u <= 0:
+ else
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ end if
+
+ end do ! do k
+ end if ! if (cell1 <=
+ end do ! do iEdge
+
+ else if (config_thickness_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+
+ end do ! do k
+ end if ! if (cell1 <=
+ end do ! do iEdge
+
+ endif ! if(config_thickness_adv_order == 2)
+
+ !
! set the velocity in the nEdges+1 slot to zero, this is a dummy address
! used to when reading for edges that do not exist
!
@@ -1322,8 +1530,8 @@
do k=1,nVertLevels
! Linear equation of state, for the time being
rho(k,iCell) = 1000.0*( 1.0 &
- - 2.5e-4*tracers(index_temperature,k,iCell) &
- + 7.6e-4*tracers(index_salinity,k,iCell))
+ - 2.5e-4*tracers(s % index_temperature,k,iCell) &
+ + 7.6e-4*tracers(s % index_salinity,k,iCell))
end do
end do
endif
@@ -1458,8 +1666,8 @@
implicit none
- type (grid_state), intent(inout) :: tend
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend
+ type (mesh_type), intent(in) :: grid
integer, dimension(:,:), pointer :: boundaryEdge
real (kind=RKIND), dimension(:,:), pointer :: tend_u
Modified: branches/swmodel_del4/src/core_ocean/mpas_interface.F
===================================================================
--- branches/swmodel_del4/src/core_ocean/mpas_interface.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_ocean/mpas_interface.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -11,7 +11,19 @@
end subroutine mpas_setup_test_case
+subroutine mpas_init_domain(domain)
+! Initialize grid variables that are computed from the netcdf input file.
+ use grid_types
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ ! This is currently a stub.
+
+end subroutine mpas_init_domain
+
subroutine mpas_init(block, mesh, dt)
use grid_types
@@ -22,21 +34,21 @@
implicit none
type (block_type), intent(inout) :: block
- type (grid_meta), intent(inout) :: mesh
+ type (mesh_type), intent(inout) :: mesh
real (kind=RKIND), intent(in) :: dt
- call compute_solve_diagnostics(dt, block % time_levs(1) % state, mesh)
+ call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
call rbfInterp_initialize(mesh)
call init_reconstruct(mesh)
- call reconstruct(block % time_levs(1) % state, mesh)
+ call reconstruct(block % state % time_levs(1) % state, mesh)
! mrp 100316 In order for this to work, we need to pass domain % dminfo as an
! input arguement into mpas_init. Ask about that later. For now, there will be
! no initial statistics write.
! call timer_start("global diagnostics")
-! call computeGlobalDiagnostics(domain % dminfo, block % time_levs(1) % state, mesh, 0, dt)
+! call computeGlobalDiagnostics(domain % dminfo, block % state % time_levs(1) % state, mesh, 0, dt)
! call timer_stop("global diagnostics")
! call output_state_init(output_obj, domain, "OUTPUT")
! call write_output_frame(output_obj, domain)
@@ -83,7 +95,7 @@
call timer_start("global diagnostics")
call computeGlobalDiagnostics(domain % dminfo, &
- block_ptr % time_levs(2) % state, block_ptr % mesh, &
+ block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
itimestep, dt)
call timer_stop("global diagnostics")
end if
Modified: branches/swmodel_del4/src/core_sw/Makefile
===================================================================
--- branches/swmodel_del4/src/core_sw/Makefile 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_sw/Makefile 2010-10-22 19:14:07 UTC (rev 578)
@@ -1,21 +1,26 @@
.SUFFIXES: .F .o
-OBJS = module_test_cases.o \
- module_time_integration.o \
- module_global_diagnostics.o \
- mpas_interface.o
+OBJS = module_test_cases.o \
+ module_advection.o \
+ module_time_integration.o \
+ module_global_diagnostics.o \
+ mpas_interface.o
all: core_sw
core_sw: $(OBJS)
ar -ru libdycore.a $(OBJS)
-module_test_cases.o:
+module_test_cases.o:
-module_time_integration.o:
+module_advection.o:
-mpas_interface.o: module_global_diagnostics.o module_test_cases.o module_time_integration.o
+module_time_integration.o:
+module_global_diagnostics.o:
+
+mpas_interface.o: module_global_diagnostics.o module_test_cases.o module_time_integration.o module_advection.o
+
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/swmodel_del4/src/core_sw/Registry
===================================================================
--- branches/swmodel_del4/src/core_sw/Registry 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_sw/Registry 2010-10-22 19:14:07 UTC (rev 578)
@@ -11,6 +11,10 @@
namelist real sw_model config_h_mom_eddy_visc4 0.0
namelist real sw_model config_h_tracer_eddy_diff2 0.0
namelist real sw_model config_h_tracer_eddy_diff4 0.0
+namelist integer sw_model config_thickness_adv_order 2
+namelist integer sw_model config_tracer_adv_order 2
+namelist logical sw_model config_positive_definite false
+namelist logical sw_model config_monotonic false
namelist character io config_input_name grid.nc
namelist character io config_output_name output.nc
namelist character io config_restart_name restart.nc
@@ -28,95 +32,114 @@
dim nVertices nVertices
dim TWO 2
dim R3 3
+dim FIFTEEN 15
+dim TWENTYONE 21
dim vertexDegree vertexDegree
dim nVertLevels nVertLevels
dim nTracers nTracers
#
-# var type name_in_file ( dims ) iro- name_in_code super-array array_class
+# var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
#
-var real xtime ( Time ) ro xtime - -
+var persistent real xtime ( Time ) 2 ro xtime state - -
-var real latCell ( nCells ) iro latCell - -
-var real lonCell ( nCells ) iro lonCell - -
-var real xCell ( nCells ) iro xCell - -
-var real yCell ( nCells ) iro yCell - -
-var real zCell ( nCells ) iro zCell - -
-var integer indexToCellID ( nCells ) iro indexToCellID - -
+var persistent real latCell ( nCells ) 0 iro latCell mesh - -
+var persistent real lonCell ( nCells ) 0 iro lonCell mesh - -
+var persistent real xCell ( nCells ) 0 iro xCell mesh - -
+var persistent real yCell ( nCells ) 0 iro yCell mesh - -
+var persistent real zCell ( nCells ) 0 iro zCell mesh - -
+var persistent integer indexToCellID ( nCells ) 0 iro indexToCellID mesh - -
-var real latEdge ( nEdges ) iro latEdge - -
-var real lonEdge ( nEdges ) iro lonEdge - -
-var real xEdge ( nEdges ) iro xEdge - -
-var real yEdge ( nEdges ) iro yEdge - -
-var real zEdge ( nEdges ) iro zEdge - -
-var integer indexToEdgeID ( nEdges ) iro indexToEdgeID - -
+var persistent real latEdge ( nEdges ) 0 iro latEdge mesh - -
+var persistent real lonEdge ( nEdges ) 0 iro lonEdge mesh - -
+var persistent real xEdge ( nEdges ) 0 iro xEdge mesh - -
+var persistent real yEdge ( nEdges ) 0 iro yEdge mesh - -
+var persistent real zEdge ( nEdges ) 0 iro zEdge mesh - -
+var persistent integer indexToEdgeID ( nEdges ) 0 iro indexToEdgeID mesh - -
-var real latVertex ( nVertices ) iro latVertex - -
-var real lonVertex ( nVertices ) iro lonVertex - -
-var real xVertex ( nVertices ) iro xVertex - -
-var real yVertex ( nVertices ) iro yVertex - -
-var real zVertex ( nVertices ) iro zVertex - -
-var integer indexToVertexID ( nVertices ) iro indexToVertexID - -
+var persistent real latVertex ( nVertices ) 0 iro latVertex mesh - -
+var persistent real lonVertex ( nVertices ) 0 iro lonVertex mesh - -
+var persistent real xVertex ( nVertices ) 0 iro xVertex mesh - -
+var persistent real yVertex ( nVertices ) 0 iro yVertex mesh - -
+var persistent real zVertex ( nVertices ) 0 iro zVertex mesh - -
+var persistent integer indexToVertexID ( nVertices ) 0 iro indexToVertexID mesh - -
-var integer cellsOnEdge ( TWO nEdges ) iro cellsOnEdge - -
-var integer nEdgesOnCell ( nCells ) iro nEdgesOnCell - -
-var integer nEdgesOnEdge ( nEdges ) iro nEdgesOnEdge - -
-var integer edgesOnCell ( maxEdges nCells ) iro edgesOnCell - -
-var integer edgesOnEdge ( maxEdges2 nEdges ) iro edgesOnEdge - -
+var persistent integer cellsOnEdge ( TWO nEdges ) 0 iro cellsOnEdge mesh - -
+var persistent integer nEdgesOnCell ( nCells ) 0 iro nEdgesOnCell mesh - -
+var persistent integer nEdgesOnEdge ( nEdges ) 0 iro nEdgesOnEdge mesh - -
+var persistent integer edgesOnCell ( maxEdges nCells ) 0 iro edgesOnCell mesh - -
+var persistent integer edgesOnEdge ( maxEdges2 nEdges ) 0 iro edgesOnEdge mesh - -
-var real weightsOnEdge ( maxEdges2 nEdges ) iro weightsOnEdge - -
-var real dvEdge ( nEdges ) iro dvEdge - -
-var real dcEdge ( nEdges ) iro dcEdge - -
-var real angleEdge ( nEdges ) iro angleEdge - -
-var real areaCell ( nCells ) iro areaCell - -
-var real areaTriangle ( nVertices ) iro areaTriangle - -
+var persistent real weightsOnEdge ( maxEdges2 nEdges ) 0 iro weightsOnEdge mesh - -
+var persistent real dvEdge ( nEdges ) 0 iro dvEdge mesh - -
+var persistent real dcEdge ( nEdges ) 0 iro dcEdge mesh - -
+var persistent real angleEdge ( nEdges ) 0 iro angleEdge mesh - -
+var persistent real areaCell ( nCells ) 0 iro areaCell mesh - -
+var persistent real areaTriangle ( nVertices ) 0 iro areaTriangle mesh - -
-var real edgeNormalVectors ( R3 nEdges ) o edgeNormalVectors - -
-var real localVerticalUnitVectors ( R3 nCells ) o localVerticalUnitVectors - -
-var real cellTangentPlane ( R3 TWO nEdges ) o cellTangentPlane - -
+var persistent real edgeNormalVectors ( R3 nEdges ) 0 o edgeNormalVectors mesh - -
+var persistent real localVerticalUnitVectors ( R3 nCells ) 0 o localVerticalUnitVectors mesh - -
+var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 o cellTangentPlane mesh - -
-var integer cellsOnCell ( maxEdges nCells ) iro cellsOnCell - -
-var integer verticesOnCell ( maxEdges nCells ) iro verticesOnCell - -
-var integer verticesOnEdge ( TWO nEdges ) iro verticesOnEdge - -
-var integer edgesOnVertex ( vertexDegree nVertices ) iro edgesOnVertex - -
-var integer cellsOnVertex ( vertexDegree nVertices ) iro cellsOnVertex - -
-var real kiteAreasOnVertex ( vertexDegree nVertices ) iro kiteAreasOnVertex - -
-var real fEdge ( nEdges ) iro fEdge - -
-var real fVertex ( nVertices ) iro fVertex - -
-var real fCell ( nCells ) iro fCell - -
-var real h_s ( nCells ) iro h_s - -
+var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
+var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
+var persistent integer verticesOnEdge ( TWO nEdges ) 0 iro verticesOnEdge mesh - -
+var persistent integer edgesOnVertex ( vertexDegree nVertices ) 0 iro edgesOnVertex mesh - -
+var persistent integer cellsOnVertex ( vertexDegree nVertices ) 0 iro cellsOnVertex mesh - -
+var persistent real kiteAreasOnVertex ( vertexDegree nVertices ) 0 iro kiteAreasOnVertex mesh - -
+var persistent real fEdge ( nEdges ) 0 iro fEdge mesh - -
+var persistent real fVertex ( nVertices ) 0 iro fVertex mesh - -
+var persistent real fCell ( nCells ) 0 iro fCell mesh - -
+var persistent real h_s ( nCells ) 0 iro h_s mesh - -
+# Space needed for advection
+var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 o deriv_two mesh - -
+var persistent integer advCells ( TWENTYONE nCells ) 0 - advCells mesh - -
+
+# !! NOTE: the following arrays are needed to allow the use
+# !! of the module_advection.F w/o alteration
+# Space needed for deformation calculation weights
+var persistent real defc_a ( maxEdges nCells ) 0 - defc_a mesh - -
+var persistent real defc_b ( maxEdges nCells ) 0 - defc_b mesh - -
+var persistent real kdiff ( nVertLevels nCells Time ) 0 - kdiff mesh - -
+
# Arrays required for reconstruction of velocity field
-var real coeffs_reconstruct ( R3 maxEdges nCells ) - coeffs_reconstruct - -
+var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 - coeffs_reconstruct mesh - -
# Boundary conditions: read from input, saved in restart and written to output
-var integer boundaryEdge ( nVertLevels nEdges ) iro boundaryEdge - -
-var integer boundaryVertex ( nVertLevels nVertices ) iro boundaryVertex - -
+var persistent integer boundaryEdge ( nVertLevels nEdges ) 0 iro boundaryEdge mesh - -
+var persistent integer boundaryVertex ( nVertLevels nVertices ) 0 iro boundaryVertex mesh - -
+var persistent integer boundaryCell ( nVertLevels nCells ) 0 iro boundaryCell mesh - -
# Prognostic variables: read from input, saved in restart, and written to output
-var real u ( nVertLevels nEdges Time ) iro u - -
-var real h ( nVertLevels nCells Time ) iro h - -
-var real tracers ( nTracers nVertLevels nCells Time ) iro tracers - -
+var persistent real u ( nVertLevels nEdges Time ) 2 iro u state - -
+var persistent real h ( nVertLevels nCells Time ) 2 iro h state - -
+var persistent real tracers ( nTracers nVertLevels nCells Time ) 2 iro tracers state - -
+# Tendency variables
+var persistent real tend_u ( nVertLevels nEdges Time ) 1 - u tend - -
+var persistent real tend_h ( nVertLevels nCells Time ) 1 - h tend - -
+var persistent real tend_tracers ( nTracers nVertLevels nCells Time ) 1 - tracers tend - -
+
# Diagnostic fields: only written to output
-var real v ( nVertLevels nEdges Time ) o v - -
-var real divergence ( nVertLevels nCells Time ) o divergence - -
-var real vorticity ( nVertLevels nVertices Time ) o vorticity - -
-var real vorticity_cell ( nVertLevels nCells Time ) o vorticity_cell - -
-var real pv_edge ( nVertLevels nEdges Time ) o pv_edge - -
-var real h_edge ( nVertLevels nEdges Time ) o h_edge - -
-var real ke ( nVertLevels nCells Time ) o ke - -
-var real pv_vertex ( nVertLevels nVertices Time ) o pv_vertex - -
-var real pv_cell ( nVertLevels nCells Time ) o pv_cell - -
-var real uReconstructX ( nVertLevels nCells Time ) o uReconstructX - -
-var real uReconstructY ( nVertLevels nCells Time ) o uReconstructY - -
-var real uReconstructZ ( nVertLevels nCells Time ) o uReconstructZ - -
-var real uReconstructZonal ( nVertLevels nCells Time ) o uReconstructZonal - -
-var real uReconstructMeridional ( nVertLevels nCells Time ) o uReconstructMeridional - -
+var persistent real v ( nVertLevels nEdges Time ) 2 o v state - -
+var persistent real divergence ( nVertLevels nCells Time ) 2 o divergence state - -
+var persistent real vorticity ( nVertLevels nVertices Time ) 2 o vorticity state - -
+var persistent real vorticity_cell ( nVertLevels nCells Time ) 2 o vorticity_cell state - -
+var persistent real pv_edge ( nVertLevels nEdges Time ) 2 o pv_edge state - -
+var persistent real h_edge ( nVertLevels nEdges Time ) 2 o h_edge state - -
+var persistent real ke ( nVertLevels nCells Time ) 2 o ke state - -
+var persistent real pv_vertex ( nVertLevels nVertices Time ) 2 o pv_vertex state - -
+var persistent real pv_cell ( nVertLevels nCells Time ) 2 o pv_cell state - -
+var persistent real uReconstructX ( nVertLevels nCells Time ) 2 o uReconstructX state - -
+var persistent real uReconstructY ( nVertLevels nCells Time ) 2 o uReconstructY state - -
+var persistent real uReconstructZ ( nVertLevels nCells Time ) 2 o uReconstructZ state - -
+var persistent real uReconstructZonal ( nVertLevels nCells Time ) 2 o uReconstructZonal state - -
+var persistent real uReconstructMeridional ( nVertLevels nCells Time ) 2 o uReconstructMeridional state - -
# Other diagnostic variables: neither read nor written to any files
-var real vh ( nVertLevels nEdges Time ) - vh - -
-var real circulation ( nVertLevels nVertices Time ) - circulation - -
-var real gradPVt ( nVertLevels nEdges Time ) - gradPVt - -
-var real gradPVn ( nVertLevels nEdges Time ) - gradPVn - -
-var real h_vertex ( nVertLevels nVertices Time ) - h_vertex - -
+var persistent real vh ( nVertLevels nEdges Time ) 2 - vh state - -
+var persistent real circulation ( nVertLevels nVertices Time ) 2 - circulation state - -
+var persistent real gradPVt ( nVertLevels nEdges Time ) 2 - gradPVt state - -
+var persistent real gradPVn ( nVertLevels nEdges Time ) 2 - gradPVn state - -
+var persistent real h_vertex ( nVertLevels nVertices Time ) 2 - h_vertex state - -
Modified: branches/swmodel_del4/src/core_sw/module_global_diagnostics.F
===================================================================
--- branches/swmodel_del4/src/core_sw/module_global_diagnostics.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_sw/module_global_diagnostics.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -37,8 +37,8 @@
implicit none
type (dm_info), intent(in) :: dminfo
- type (grid_state), intent(inout) :: state
- type (grid_meta), intent(in) :: grid
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
integer, intent(in) :: timeIndex
real (kind=RKIND), intent(in) :: dt
@@ -179,8 +179,8 @@
end do
keTend_CoriolisForce(iLevel,iEdge) = h_edge(iLevel,iEdge) * u(iLevel,iEdge) * q * areaEdge(iEdge)
- iCell1 = cellsOnEdge(iEdge,1)
- iCell2 = cellsOnEdge(iEdge,2)
+ iCell1 = cellsOnEdge(1,iEdge)
+ iCell2 = cellsOnEdge(2,iEdge)
refAreaWeightedSurfaceHeight_edge(iLevel,iEdge) = areaEdge(iEdge)*(h_edge(iLevel,iEdge) + 0.5*(h_s(iCell1) + h_s(iCell2)))
@@ -197,8 +197,8 @@
end do
do iEdge = 1,nEdgesSolve
- iCell1 = cellsOnEdge(iEdge,1)
- iCell2 = cellsOnEdge(iEdge,2)
+ iCell1 = cellsOnEdge(1,iEdge)
+ iCell2 = cellsOnEdge(2,iEdge)
h_s_edge(iEdge) = 0.5*(h_s(iCell1) + h_s(iCell2))
end do
Modified: branches/swmodel_del4/src/core_sw/module_test_cases.F
===================================================================
--- branches/swmodel_del4/src/core_sw/module_test_cases.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_sw/module_test_cases.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -33,9 +33,9 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call sw_test_case_1(block_ptr % mesh, block_ptr % time_levs(1) % state)
+ call sw_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
+ call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
end do
block_ptr => block_ptr % next
@@ -47,9 +47,9 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call sw_test_case_2(block_ptr % mesh, block_ptr % time_levs(1) % state)
+ call sw_test_case_2(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
+ call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
end do
block_ptr => block_ptr % next
@@ -61,9 +61,9 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call sw_test_case_5(block_ptr % mesh, block_ptr % time_levs(1) % state)
+ call sw_test_case_5(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
+ call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
end do
block_ptr => block_ptr % next
@@ -75,9 +75,9 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call sw_test_case_6(block_ptr % mesh, block_ptr % time_levs(1) % state)
+ call sw_test_case_6(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
+ call copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
end do
block_ptr => block_ptr % next
@@ -102,8 +102,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
real (kind=RKIND), parameter :: h0 = 1000.0
@@ -148,9 +148,6 @@
psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
) / grid%dvEdge%array(iEdge)
-#ifdef EXPAND_LEVELS
- state % u % array(2:EXPAND_LEVELS, iEdge) = state % u % array(1,iEdge)
-#endif
end do
deallocate(psiVertex)
@@ -164,9 +161,6 @@
else
state % h % array(1,iCell) = 0.0
end if
-#ifdef EXPAND_LEVELS
- state % h % array(2:EXPAND_LEVELS, iCell) = state % h % array(1,iCell)
-#endif
end do
end subroutine sw_test_case_1
@@ -184,8 +178,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0)
real (kind=RKIND), parameter :: gh0 = 29400.0
@@ -230,9 +224,6 @@
psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
) / grid%dvEdge%array(iEdge)
-#ifdef EXPAND_LEVELS
- state % u % array(2:EXPAND_LEVELS, iEdge) = state % u % array(1,iEdge)
-#endif
end do
deallocate(psiVertex)
@@ -262,9 +253,6 @@
)**2.0 &
) / &
gravity
-#ifdef EXPAND_LEVELS
- state % h % array(2:EXPAND_LEVELS, iCell) = state % h % array(1,iCell)
-#endif
end do
end subroutine sw_test_case_2
@@ -281,8 +269,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
real (kind=RKIND), parameter :: u0 = 20.
real (kind=RKIND), parameter :: gh0 = 5960.0*gravity
@@ -330,9 +318,6 @@
psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
) / grid%dvEdge%array(iEdge)
-#ifdef EXPAND_LEVELS
- state % u % array(2:EXPAND_LEVELS, iEdge) = state % u % array(1,iEdge)
-#endif
end do
deallocate(psiVertex)
@@ -389,9 +374,6 @@
) / &
gravity
state % h % array(1,iCell) = state % h % array(1,iCell) - grid % h_s % array(iCell)
-#ifdef EXPAND_LEVELS
- state % h % array(2:EXPAND_LEVELS, iCell) = state % h % array(1,iCell)
-#endif
end do
end subroutine sw_test_case_5
@@ -408,8 +390,8 @@
implicit none
- type (grid_meta), intent(inout) :: grid
- type (grid_state), intent(inout) :: state
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
real (kind=RKIND), parameter :: h0 = 8000.0
real (kind=RKIND), parameter :: w = 7.848e-6
@@ -453,9 +435,6 @@
psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
) / grid%dvEdge%array(iEdge)
-#ifdef EXPAND_LEVELS
- state % u % array(2:EXPAND_LEVELS, iEdge) = state % u % array(1,iEdge)
-#endif
end do
deallocate(psiVertex)
@@ -467,9 +446,6 @@
a*a*BB(grid%latCell%array(iCell)) * cos(R*grid%lonCell%array(iCell)) + &
a*a*CC(grid%latCell%array(iCell)) * cos(2.0*R*grid%lonCell%array(iCell)) &
) / gravity
-#ifdef EXPAND_LEVELS
- state % h % array(2:EXPAND_LEVELS, iCell) = state % h % array(1,iCell)
-#endif
end do
end subroutine sw_test_case_6
Modified: branches/swmodel_del4/src/core_sw/module_time_integration.F
===================================================================
--- branches/swmodel_del4/src/core_sw/module_time_integration.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_sw/module_time_integration.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -37,7 +37,7 @@
block => domain % blocklist
do while (associated(block))
- block % time_levs(2) % state % xtime % scalar = block % time_levs(1) % state % xtime % scalar + dt
+ block % state % time_levs(2) % state % xtime % scalar = block % state % time_levs(1) % state % xtime % scalar + dt
block => block % next
end do
@@ -62,13 +62,17 @@
integer :: iCell, k
type (block_type), pointer :: block
+ type (state_type) :: provis
- integer, parameter :: PROVIS = 1
- integer, parameter :: TEND = 2
integer :: rk_step
real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights
+ block => domain % blocklist
+ call allocate_state(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)
!
! Initialize time_levs(2) with state at current time
@@ -79,16 +83,16 @@
block => domain % blocklist
do while (associated(block))
- block % time_levs(2) % state % u % array(:,:) = block % time_levs(1) % state % u % array(:,:)
- block % time_levs(2) % state % h % array(:,:) = block % time_levs(1) % state % h % array(:,:)
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
do iCell=1,block % mesh % nCells ! couple tracers to h
do k=1,block % mesh % nVertLevels
- block % time_levs(2) % state % tracers % array(:,k,iCell) = block % time_levs(1) % state % tracers % array(:,k,iCell) &
- * block % time_levs(1) % state % h % array(k,iCell)
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ * block % state % time_levs(1) % state % h % array(k,iCell)
end do
end do
- call copy_state(block % time_levs(1) % state, block % intermediate_step(PROVIS))
+ call copy_state(provis, block % state % time_levs(1) % state)
block => block % next
end do
@@ -113,15 +117,15 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(PROVIS) % pv_edge % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, provis % 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 dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % divergence % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % time_levs(2) % state % vorticity % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
block % mesh % nVertLevels, block % mesh % nVertices, &
block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
end if
@@ -133,9 +137,9 @@
block => domain % blocklist
do while (associated(block))
- call compute_tend(block % intermediate_step(TEND), block % intermediate_step(PROVIS), block % mesh)
- call compute_scalar_tend(block % intermediate_step(TEND), block % intermediate_step(PROVIS), block % mesh)
- call enforce_boundaryEdge(block % intermediate_step(TEND), block % mesh)
+ call compute_tend(block % tend, provis, block % mesh)
+ call compute_scalar_tend(block % tend, provis, block % mesh)
+ call enforce_boundaryEdge(block % tend, block % mesh)
block => block % next
end do
@@ -143,13 +147,13 @@
block => domain % blocklist
do while (associated(block))
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(TEND) % u % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % u % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call dmpar_exch_halo_field2dReal(domain % dminfo, block % intermediate_step(TEND) % h % array(:,:), &
+ call dmpar_exch_halo_field2dReal(domain % dminfo, block % tend % h % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call dmpar_exch_halo_field3dReal(domain % dminfo, block % intermediate_step(TEND) % tracers % array(:,:,:), &
+ call dmpar_exch_halo_field3dReal(domain % dminfo, block % tend % tracers % array(:,:,:), &
block % mesh % nTracers, block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
block => block % next
@@ -160,23 +164,23 @@
if (rk_step < 4) then
block => domain % blocklist
do while (associated(block))
- block % intermediate_step(PROVIS) % u % array(:,:) = block % time_levs(1) % state % u % array(:,:) &
- + rk_substep_weights(rk_step) * block % intermediate_step(TEND) % u % array(:,:)
- block % intermediate_step(PROVIS) % h % array(:,:) = block % time_levs(1) % state % h % array(:,:) &
- + rk_substep_weights(rk_step) * block % intermediate_step(TEND) % h % array(:,:)
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) &
+ + rk_substep_weights(rk_step) * block % tend % u % array(:,:)
+ provis % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:) &
+ + rk_substep_weights(rk_step) * block % tend % h % array(:,:)
do iCell=1,block % mesh % nCells
do k=1,block % mesh % nVertLevels
- block % intermediate_step(PROVIS) % tracers % array(:,k,iCell) = ( &
- block % time_levs(1) % state % h % array(k,iCell) * &
- block % time_levs(1) % state % tracers % array(:,k,iCell) &
- + rk_substep_weights(rk_step) * block % intermediate_step(TEND) % tracers % array(:,k,iCell) &
- ) / block % intermediate_step(PROVIS) % h % array(k,iCell)
+ provis % tracers % array(:,k,iCell) = ( &
+ block % state % time_levs(1) % state % h % array(k,iCell) * &
+ block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ + rk_substep_weights(rk_step) * block % tend % tracers % array(:,k,iCell) &
+ ) / provis % h % array(k,iCell)
end do
end do
if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % intermediate_step(PROVIS) % u % array(:,:) = block % time_levs(1) % state % u % array(:,:)
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
- call compute_solve_diagnostics(dt, block % intermediate_step(PROVIS), block % mesh)
+ call compute_solve_diagnostics(dt, provis, block % mesh)
block => block % next
end do
end if
@@ -185,15 +189,15 @@
block => domain % blocklist
do while (associated(block))
- block % time_levs(2) % state % u % array(:,:) = block % time_levs(2) % state % u % array(:,:) &
- + rk_weights(rk_step) * block % intermediate_step(TEND) % u % array(:,:)
- block % time_levs(2) % state % h % array(:,:) = block % time_levs(2) % state % h % array(:,:) &
- + rk_weights(rk_step) * block % intermediate_step(TEND) % h % array(:,:)
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % u % array(:,:) &
+ + rk_weights(rk_step) * block % tend % u % array(:,:)
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(2) % state % h % array(:,:) &
+ + rk_weights(rk_step) * block % tend % h % array(:,:)
do iCell=1,block % mesh % nCells
do k=1,block % mesh % nVertLevels
- block % time_levs(2) % state % tracers % array(:,k,iCell) = &
- block % time_levs(2) % state % tracers % array(:,k,iCell) &
- + rk_weights(rk_step) * block % intermediate_step(TEND) % tracers % array(:,k,iCell)
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ + rk_weights(rk_step) * block % tend % tracers % array(:,k,iCell)
end do
end do
block => block % next
@@ -212,23 +216,25 @@
do while (associated(block))
do iCell=1,block % mesh % nCells
do k=1,block % mesh % nVertLevels
- block % time_levs(2) % state % tracers % array(:,k,iCell) = &
- block % time_levs(2) % state % tracers % array(:,k,iCell) &
- / block % time_levs(2) % state % h % array(k,iCell)
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ / block % state % time_levs(2) % state % h % array(k,iCell)
end do
end do
if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % time_levs(2) % state % u % array(:,:) = block % time_levs(1) % state % u % array(:,:)
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
- call compute_solve_diagnostics(dt, block % time_levs(2) % state, block % mesh)
+ call compute_solve_diagnostics(dt, block % state % time_levs(2) % state, block % mesh)
- call reconstruct(block % time_levs(2) % state, block % mesh)
+ call reconstruct(block % state % time_levs(2) % state, block % mesh)
block => block % next
end do
+ call deallocate_state(provis)
+
end subroutine rk4
@@ -244,9 +250,9 @@
implicit none
- type (grid_state), intent(inout) :: tend
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
real (kind=RKIND) :: flux, vorticity_abs, workpv, q, upstream_bias
@@ -514,46 +520,171 @@
implicit none
- type (grid_state), intent(inout) :: tend
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
- integer :: iCell, iEdge, k, iTracer, cell1, cell2
+ integer :: iCell, iEdge, k, iTracer, cell1, cell2, i
real (kind=RKIND) :: flux, tracer_edge, r
real (kind=RKIND) :: h_tracer_eddy_diff2, h_tracer_eddy_diff4, invAreaCell1, invAreaCell2, tracer_turb_flux
integer, dimension(:,:), pointer :: boundaryEdge
real (kind=RKIND), dimension(:,:), allocatable :: boundaryMask
real (kind=RKIND), dimension(:,:,:), allocatable:: delsq_tracer
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers, tracer_tend
+ integer, dimension(:,:), pointer :: cellsOnEdge, boundaryCell
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND) :: coef_3rd_order
+ real (kind=RKIND), dimension(:,:), pointer :: u, h_edge
+
+ u => s % u % array
+ h_edge => s % h_edge % array
+ dcEdge => grid % dcEdge % array
+ deriv_two => grid % deriv_two % array
+ dvEdge => grid % dvEdge % array
+ tracers => s % tracers % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ boundaryCell=> grid % boundaryCell % array
boundaryEdge => grid % boundaryEdge % array
+ areaCell => grid % areaCell % array
+ tracer_tend => tend % tracers % array
+ coef_3rd_order = 0.
+ if (config_tracer_adv_order == 3) coef_3rd_order = 1.0
+ if (config_tracer_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
h_tracer_eddy_diff2 = config_h_tracer_eddy_diff2
h_tracer_eddy_diff4 = config_h_tracer_eddy_diff4
- tend % tracers % array(:,:,:) = 0.0
+ tracer_tend(:,:,:) = 0.0
+
+ if (config_tracer_adv_order == 2) then
+
do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
do k=1,grid % nVertLevels
do iTracer=1,grid % nTracers
- tracer_edge = 0.5 * (s % tracers % array(iTracer,k,cell1) + s % tracers % array(iTracer,k,cell2))
- flux = s % u % array(k,iEdge) * grid % dvEdge % array(iEdge) * s % h_edge % array(k,iEdge) * tracer_edge
- tend % tracers % array(iTracer,k,cell1) = tend % tracers % array(iTracer,k,cell1) - flux
- tend % tracers % array(iTracer,k,cell2) = tend % tracers % array(iTracer,k,cell2) + flux
+ tracer_edge = 0.5 * (tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2))
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) * tracer_edge
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
end do
end do
end if
end do
- do iCell=1,grid % nCellsSolve
- do k=1,grid % nVertLevelsSolve
- do iTracer=1,grid % nTracers
- tend % tracers % array(iTracer,k,iCell) = tend % tracers % array(iTracer,k,iCell) / grid % areaCell % array(iCell)
- end do
+ else if (config_tracer_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ do iTracer=1,grid % nTracers
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ !-- if u > 0:
+ if (u(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ !-- else u <= 0:
+ else
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ end if
+
+ !-- update tendency
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ enddo
+ end do
+ end if
end do
- end do
+ else if (config_tracer_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if an edge is not on the outer-most ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ do iTracer=1,grid % nTracers
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
+
+ !-- update tendency
+ tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1)
+ tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ enddo
+ end do
+ end if
+ end do
+
+ endif ! if (config_tracer_adv_order == 2 )
+
!
! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 </font>
<font color="gray">abla \phi)
!
@@ -682,8 +813,8 @@
implicit none
real (kind=RKIND), intent(in) :: dt
- type (grid_state), intent(inout) :: s
- type (grid_meta), intent(in) :: grid
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
@@ -694,11 +825,13 @@
real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, divergence, &
h_vertex, vorticity_cell
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge, boundaryCell
integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
real (kind=RKIND) :: r, h1, h2
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND) :: coef_3rd_order
-
h => s % h % array
u => s % u % array
v => s % v % array
@@ -735,6 +868,7 @@
h_s => grid % h_s % array
fVertex => grid % fVertex % array
fEdge => grid % fEdge % array
+ deriv_two => grid % deriv_two % array
nCells = grid % nCells
nEdges = grid % nEdges
@@ -742,21 +876,141 @@
nVertLevels = grid % nVertLevels
boundaryEdge => grid % boundaryEdge % array
+ boundaryCell => grid % boundaryCell % array
!
- ! Compute height on cell edges at velocity locations
+ ! Find those cells that have an edge on the boundary
!
+ boundaryCell(:,:) = 0
do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCells .and. cell2 <= nCells) then
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end if
- end do
+ do k=1,nVertLevels
+ if(boundaryEdge(k,iEdge).eq.1) then
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ boundaryCell(k,cell1) = 1
+ boundaryCell(k,cell2) = 1
+ endif
+ enddo
+ enddo
!
+ ! Compute height on cell edges at velocity locations
+ ! Namelist options control the order of accuracy of the reconstructed h_edge value
+ !
+
+ coef_3rd_order = 0.
+ if (config_thickness_adv_order == 3) coef_3rd_order = 1.0
+ if (config_thickness_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+ if (config_thickness_adv_order == 2) then
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+ do k=1,grid % nVertLevels
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
+ end if
+ end do
+
+ else if (config_thickness_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ !-- if u > 0:
+ if (u(k,iEdge) > 0) then
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ !-- else u <= 0:
+ else
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ end if
+
+ end do ! do k
+ end if ! if (cell1 <=
+ end do ! do iEdge
+
+ else if (config_thickness_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ !-- if a cell not on the most outside ring of the halo
+ if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
+
+ !-- if not a boundary cell
+ if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+
+ !-- all edges of cell 1
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
+
+ !-- all edges of cell 2
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ endif
+
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+
+ end do ! do k
+ end if ! if (cell1 <=
+ end do ! do iEdge
+
+ endif ! if(config_thickness_adv_order == 2)
+
+ !
! set the velocity in the nEdges+1 slot to zero, this is a dummy address
! used to when reading for edges that do not exist
!
@@ -995,8 +1249,8 @@
implicit none
- type (grid_state), intent(inout) :: tend
- type (grid_meta), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend
+ type (mesh_type), intent(in) :: grid
integer, dimension(:,:), pointer :: boundaryEdge
real (kind=RKIND), dimension(:,:), pointer :: tend_u
Modified: branches/swmodel_del4/src/core_sw/mpas_interface.F
===================================================================
--- branches/swmodel_del4/src/core_sw/mpas_interface.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/core_sw/mpas_interface.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -12,6 +12,20 @@
end subroutine mpas_setup_test_case
+subroutine mpas_init_domain(domain)
+! Initialize grid variables that are computed from the netcdf input file.
+
+ use grid_types
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ ! This is currently a stub.
+
+end subroutine mpas_init_domain
+
+
subroutine mpas_init(block, mesh, dt)
use grid_types
@@ -22,14 +36,14 @@
implicit none
type (block_type), intent(inout) :: block
- type (grid_meta), intent(inout) :: mesh
+ type (mesh_type), intent(inout) :: mesh
real (kind=RKIND), intent(in) :: dt
- call compute_solve_diagnostics(dt, block % time_levs(1) % state, mesh)
+ call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
call rbfInterp_initialize(mesh)
call init_reconstruct(mesh)
- call reconstruct(block % time_levs(1) % state, mesh)
+ call reconstruct(block % state % time_levs(1) % state, mesh)
end subroutine mpas_init
@@ -74,7 +88,7 @@
call timer_start("global_diagnostics")
call computeGlobalDiagnostics(domain % dminfo, &
- block_ptr % time_levs(2) % state, block_ptr % mesh, &
+ block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
itimestep, dt)
call timer_stop("global_diagnostics")
end if
Modified: branches/swmodel_del4/src/driver/module_subdriver.F
===================================================================
--- branches/swmodel_del4/src/driver/module_subdriver.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/driver/module_subdriver.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -13,7 +13,7 @@
subroutine mpas_init(block, mesh, dt)
use grid_types
type (block_type), intent(inout) :: block
- type (grid_meta), intent(inout) :: mesh
+ type (mesh_type), intent(inout) :: mesh
real (kind=RKIND), intent(in) :: dt
end subroutine mpas_init
@@ -59,7 +59,7 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
call mpas_init(block_ptr, block_ptr % mesh, dt)
- if (.not. config_do_restart) block_ptr % time_levs(1) % state % xtime % scalar = 0.0
+ if (.not. config_do_restart) block_ptr % state % time_levs(1) % state % xtime % scalar = 0.0
block_ptr => block_ptr % next
end do
@@ -79,7 +79,7 @@
call timer_stop("time integration")
! Move time level 2 fields back into time level 1 for next time step
- call shift_time_levels(domain)
+ call shift_time_levels_state(domain % blocklist % state)
if (mod(itimestep, config_output_interval) == 0) then
call write_output_frame(output_obj, domain)
@@ -116,7 +116,7 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % time_levs(1) % state, block_ptr % mesh)
+ call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
block_ptr => block_ptr % next
end do
@@ -138,8 +138,8 @@
implicit none
- type (grid_state), intent(inout) :: state
- type (grid_meta), intent(in) :: grid
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
integer :: i, eoe
integer :: iEdge, k
Modified: branches/swmodel_del4/src/driver/mpas.F
===================================================================
--- branches/swmodel_del4/src/driver/mpas.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/driver/mpas.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -32,6 +32,8 @@
call input_state_for_domain(domain)
+ call mpas_init_domain(domain)
+
if (.not. config_do_restart) call mpas_setup_test_case(domain)
call timer_stop("initialize")
Modified: branches/swmodel_del4/src/framework/module_block_decomp.F
===================================================================
--- branches/swmodel_del4/src/framework/module_block_decomp.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/framework/module_block_decomp.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -147,7 +147,9 @@
do j=1,maxCells
if (cellsOnEdge(j,i) /= 0) exit
end do
-if (j > maxCells) write(0,*) 'Error in block_decomp_partitioned_edge_list: edge/vertex is not adjacent to any valid cells'
+ if (j > maxCells) &
+ write(0,*) 'Error in block_decomp_partitioned_edge_list: ',&
+ 'edge/vertex is not adjacent to any valid cells'
if (hash_search(h, cellsOnEdge(j,i))) then
lastEdge = lastEdge + 1
edgeIDList(lastEdge) = edgeIDListLocal(i)
@@ -155,14 +157,16 @@
ghostEdgeStart = ghostEdgeStart - 1
edgeIDList(ghostEdgeStart) = edgeIDListLocal(i)
end if
-if (ghostEdgeStart <= lastEdge) then
- write(0,*) 'block_decomp_partitioned_edge_list: Somehow we have more edges than we thought we should.'
-end if
+ if (ghostEdgeStart <= lastEdge) then
+ write(0,*) 'block_decomp_partitioned_edge_list: ',&
+ 'Somehow we have more edges than we thought we should.'
+ end if
end do
-if (ghostEdgeStart /= lastEdge + 1) then
- write(0,*) 'block_decomp_partitioned_edge_list: Somehow we didn''t have enough edges to fill edgeIDList.'
-end if
+ if (ghostEdgeStart /= lastEdge + 1) then
+ write(0,*) 'block_decomp_partitioned_edge_list:',&
+ ' Somehow we didn''t have enough edges to fill edgeIDList.'
+ end if
call hash_destroy(h)
@@ -202,10 +206,11 @@
do j=1,nEdgesOnCell(i)
if (.not. hash_search(h, edgesOnCell(j,i))) then
k = k + 1
-if (k > nEdges) then
- write(0,*) 'block_decomp_all_edges_in_block: Trying to add more edges than expected.'
- return
-end if
+ if (k > nEdges) then
+ write(0,*) 'block_decomp_all_edges_in_block: ',&
+ 'Trying to add more edges than expected.'
+ return
+ end if
edgeList(k) = edgesOnCell(j,i)
call hash_insert(h, edgesOnCell(j,i))
end if
@@ -214,9 +219,10 @@
call hash_destroy(h)
-if (k < nEdges) then
- write(0,*) 'block_decomp_all_edges_in_block: Listed fewer edges than expected.'
-end if
+ if (k < nEdges) then
+ write(0,*) 'block_decomp_all_edges_in_block: ',&
+ 'Listed fewer edges than expected.'
+ end if
end subroutine block_decomp_all_edges_in_block
@@ -236,6 +242,10 @@
call hash_init(h)
do i=1,local_graph_info % nVertices
+ call hash_insert(h, local_graph_info % vertexID(i))
+ end do
+
+ do i=1,local_graph_info % nVertices
do j=1,local_graph_info % nAdjacent(i)
if (local_graph_info % adjacencyList(j,i) /= 0) then
if (.not. hash_search(h, local_graph_info % adjacencyList(j,i))) then
@@ -259,8 +269,9 @@
call hash_init(h)
do i=1,local_graph_info % nVertices
-if (hash_search(h, local_graph_info % vertexID(i))) &
- write(0,*) 'block_decomp_add_halo: There appear to be duplicates in vertexID list.'
+ if (hash_search(h, local_graph_info % vertexID(i))) &
+ write(0,*) 'block_decomp_add_halo: ', &
+ 'There appear to be duplicates in vertexID list.'
call hash_insert(h, local_graph_info % vertexID(i))
local_graph_with_halo % vertexID(i) = local_graph_info % vertexID(i)
local_graph_with_halo % nAdjacent(i) = local_graph_info % nAdjacent(i)
@@ -268,8 +279,9 @@
end do
k = local_graph_with_halo % ghostStart
-if (hash_size(h) /= k-1) &
- write(0,*) 'block_decomp_add_halo: Somehow we don''t have the right number of non-ghost cells.'
+ if (hash_size(h) /= k-1) &
+ write(0,*) 'block_decomp_add_halo: ',&
+ 'Somehow we don''t have the right number of non-ghost cells.'
do i=1,local_graph_info % nVertices
do j=1,local_graph_info % nAdjacent(i)
if (local_graph_info % adjacencyList(j,i) /= 0) then
@@ -281,8 +293,9 @@
end if
end do
end do
-if (local_graph_with_halo % nVerticesTotal /= k-1) &
- write(0,*) 'block_decomp_add_halo: Somehow we don''t have the right number of total cells.'
+ if (local_graph_with_halo % nVerticesTotal /= k-1) &
+ write(0,*) 'block_decomp_add_halo: ',&
+ 'Somehow we don''t have the right number of total cells.'
call hash_destroy(h)
Modified: branches/swmodel_del4/src/framework/module_dmpar.F
===================================================================
--- branches/swmodel_del4/src/framework/module_dmpar.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/framework/module_dmpar.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -4,6 +4,7 @@
#ifdef _MPI
include 'mpif.h'
+ integer, parameter :: MPI_INTEGERKIND = MPI_INTEGER
#if (RKIND == 8)
integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION
@@ -64,7 +65,8 @@
dminfo % nprocs = mpi_size
dminfo % my_proc_id = mpi_rank
- write(0,'(a,i5,a,i5,a)') 'task ', mpi_rank, ' of ', mpi_size, ' is running'
+ write(0,'(a,i5,a,i5,a)') 'task ', mpi_rank, ' of ', mpi_size, &
+ ' is running'
call open_streams(dminfo % my_proc_id)
@@ -139,7 +141,7 @@
#ifdef _MPI
integer :: mpi_ierr
- call MPI_Bcast(i, 1, MPI_INTEGER, IO_NODE, dminfo % comm, mpi_ierr)
+ call MPI_Bcast(i, 1, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
#endif
end subroutine dmpar_bcast_int
@@ -156,7 +158,7 @@
#ifdef _MPI
integer :: mpi_ierr
- call MPI_Bcast(iarray, n, MPI_INTEGER, IO_NODE, dminfo % comm, mpi_ierr)
+ call MPI_Bcast(iarray, n, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
#endif
end subroutine dmpar_bcast_ints
@@ -214,7 +216,7 @@
end if
end if
- call MPI_Bcast(itemp, 1, MPI_INTEGER, IO_NODE, dminfo % comm, mpi_ierr)
+ call MPI_Bcast(itemp, 1, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
if (itemp == 1) then
l = .true.
@@ -253,7 +255,7 @@
integer :: mpi_ierr
#ifdef _MPI
- call MPI_Allreduce(i, isum, 1, MPI_INTEGER, MPI_SUM, dminfo % comm, mpi_ierr)
+ call MPI_Allreduce(i, isum, 1, MPI_INTEGERKIND, MPI_SUM, dminfo % comm, mpi_ierr)
#else
isum = i
#endif
@@ -291,7 +293,7 @@
integer :: mpi_ierr
#ifdef _MPI
- call MPI_Allreduce(i, imin, 1, MPI_INTEGER, MPI_MIN, dminfo % comm, mpi_ierr)
+ call MPI_Allreduce(i, imin, 1, MPI_INTEGERKIND, MPI_MIN, dminfo % comm, mpi_ierr)
#else
imin = i
#endif
@@ -329,7 +331,7 @@
integer :: mpi_ierr
#ifdef _MPI
- call MPI_Allreduce(i, imax, 1, MPI_INTEGER, MPI_MAX, dminfo % comm, mpi_ierr)
+ call MPI_Allreduce(i, imax, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
#else
imax = i
#endif
@@ -368,7 +370,7 @@
integer :: mpi_ierr
#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGER, MPI_SUM, dminfo % comm, mpi_ierr)
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_SUM, dminfo % comm, mpi_ierr)
#else
outArray = inArray
#endif
@@ -388,7 +390,7 @@
integer :: mpi_ierr
#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGER, MPI_MIN, dminfo % comm, mpi_ierr)
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_MIN, dminfo % comm, mpi_ierr)
#else
outArray = inArray
#endif
@@ -408,7 +410,7 @@
integer :: mpi_ierr
#ifdef _MPI
- call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGER, MPI_MAX, dminfo % comm, mpi_ierr)
+ call MPI_Allreduce(inArray, outArray, nElements, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
#else
outArray = inArray
#endif
@@ -489,7 +491,7 @@
#ifdef _MPI
integer :: mpi_ierr
- call MPI_Scatterv(inlist, counts, displs, MPI_INTEGER, outlist, noutlist, MPI_INTEGER, IO_NODE, dminfo % comm, mpi_ierr)
+ call MPI_Scatterv(inlist, counts, displs, MPI_INTEGERKIND, outlist, noutlist, MPI_INTEGERKIND, IO_NODE, dminfo % comm, mpi_ierr)
#endif
end subroutine dmpar_scatter_ints
@@ -532,13 +534,13 @@
#ifdef _MPI
else if (dminfo % my_proc_id == dminfo % nprocs - 1) then
- call MPI_Recv(global_start, 1, MPI_INTEGER, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Recv(global_start, 1, MPI_INTEGERKIND, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
global_end = global_start + n - 1
else
- call MPI_Recv(global_start, 1, MPI_INTEGER, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
+ call MPI_Recv(global_start, 1, MPI_INTEGERKIND, dminfo % my_proc_id - 1, 0, dminfo % comm, MPI_STATUS_IGNORE, mpi_ierr)
global_end = global_start + n
- call MPI_Send(global_end, 1, MPI_INTEGER, dminfo % my_proc_id + 1, 0, dminfo % comm, mpi_ierr)
+ call MPI_Send(global_end, 1, MPI_INTEGERKIND, dminfo % my_proc_id + 1, 0, dminfo % comm, mpi_ierr)
global_end = global_end - 1
#endif
@@ -585,7 +587,7 @@
end do
call quicksort(nOwnedList, ownedListSorted)
- call MPI_Allreduce(nNeededList, totalSize, 1, MPI_INTEGER, MPI_MAX, dminfo % comm, mpi_ierr)
+ call MPI_Allreduce(nNeededList, totalSize, 1, MPI_INTEGERKIND, MPI_MAX, dminfo % comm, mpi_ierr)
allocate(ownerListIn(totalSize))
allocate(ownerListOut(totalSize))
@@ -634,12 +636,12 @@
end if
nMesgSend = nMesgRecv
- call MPI_Irecv(nMesgRecv, 1, MPI_INTEGER, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
- call MPI_Isend(nMesgSend, 1, MPI_INTEGER, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Irecv(nMesgRecv, 1, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(nMesgSend, 1, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
- call MPI_Irecv(ownerListIn, nMesgRecv, MPI_INTEGER, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
- call MPI_Isend(ownerListOut, nMesgSend, MPI_INTEGER, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
+ call MPI_Irecv(ownerListIn, nMesgRecv, MPI_INTEGERKIND, recvNeighbor, i, dminfo % comm, mpi_rreq, mpi_ierr)
+ call MPI_Isend(ownerListOut, nMesgSend, MPI_INTEGERKIND, sendNeighbor, i, dminfo % comm, mpi_sreq, mpi_ierr)
call MPI_Wait(mpi_rreq, MPI_STATUS_IGNORE, mpi_ierr)
call MPI_Wait(mpi_sreq, MPI_STATUS_IGNORE, mpi_ierr)
end do
@@ -741,7 +743,7 @@
do while (associated(recvListPtr))
if (recvListPtr % procID /= dminfo % my_proc_id) then
allocate(recvListPtr % ibuffer(recvListPtr % nlist))
- call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGER, &
+ call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
end if
recvListPtr => recvListPtr % next
@@ -753,7 +755,7 @@
allocate(sendListPtr % ibuffer(sendListPtr % nlist))
call packSendBuf1dInteger(nOwnedList, arrayIn, sendListPtr, 1, sendListPtr % nlist, &
sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGER, &
+ call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
end if
sendListPtr => sendListPtr % next
@@ -781,7 +783,8 @@
#else
if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
@@ -831,7 +834,7 @@
if (recvListPtr % procID /= dminfo % my_proc_id) then
d2 = dim1 * recvListPtr % nlist
allocate(recvListPtr % ibuffer(d2))
- call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGER, &
+ call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
end if
recvListPtr => recvListPtr % next
@@ -844,7 +847,7 @@
allocate(sendListPtr % ibuffer(d2))
call packSendBuf2dInteger(1, dim1, nOwnedList, arrayIn, sendListPtr, 1, d2, &
sendListPtr % ibuffer, nPacked, lastPackedIdx)
- call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGER, &
+ call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
end if
sendListPtr => sendListPtr % next
@@ -873,7 +876,8 @@
#else
if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
@@ -962,7 +966,8 @@
#else
if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
arrayOut(1:nNeededList) = arrayIn(1:nOwnedList)
@@ -1054,7 +1059,8 @@
#else
if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
arrayOut(:,1:nNeededList) = arrayIn(:,1:nOwnedList)
@@ -1146,7 +1152,8 @@
#else
if (nOwnedList /= nNeededList) then
- write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, arrayIn and arrayOut dims must match.'
+ write(0,*) 'Error in dmpar_alltoall_field: For non-dmpar, ', &
+ 'arrayIn and arrayOut dims must match.'
call dmpar_abort(dminfo)
else
arrayOut(:,:,1:nNeededList) = arrayIn(:,:,1:nOwnedList)
@@ -1198,7 +1205,8 @@
n = de-ds+1
if (n > nBuffer) then
- write(0,*) 'packSendBuf2dInteger: Not enough space in buffer to fit a single slice.'
+ write(0,*) 'packSendBuf2dInteger: Not enough space in buffer', &
+ ' to fit a single slice.'
return
end if
@@ -1217,6 +1225,45 @@
end subroutine packSendBuf2dInteger
+ subroutine packSendBuf3dInteger(d1s, d1e, d2s, d2e, nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startPackIdx
+ integer, dimension(d1s:d1e,d2s:d2e,*), intent(in) :: field
+ type (exchange_list), intent(in) :: sendList
+ integer, dimension(nBuffer), intent(out) :: buffer
+ integer, intent(inout) :: nPacked, lastPackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ if (n > nBuffer) then
+ write(0,*) 'packSendBuf3dInteger: Not enough space in buffer', &
+ ' to fit a single slice.'
+ return
+ end if
+
+ nPacked = 0
+ do i=startPackIdx, sendList % nlist
+ nPacked = nPacked + n
+ if (nPacked > nBuffer) then
+ nPacked = nPacked - n
+ lastPackedIdx = i - 1
+ return
+ end if
+ k = nPacked-n+1
+ do j=d2s,d2e
+ buffer(k:k+d1e-d1s) = field(d1s:d1e,j,sendList % list(i))
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastPackedIdx = sendList % nlist
+
+ end subroutine packSendBuf3dInteger
+
+
subroutine packSendBuf1dReal(nField, field, sendList, startPackIdx, nBuffer, buffer, nPacked, lastPackedIdx)
implicit none
@@ -1259,7 +1306,8 @@
n = de-ds+1
if (n > nBuffer) then
- write(0,*) 'packSendBuf2dReal: Not enough space in buffer to fit a single slice.'
+ write(0,*) 'packSendBuf2dReal: Not enough space in buffer', &
+ ' to fit a single slice.'
return
end if
@@ -1293,7 +1341,8 @@
n = (d1e-d1s+1) * (d2e-d2s+1)
if (n > nBuffer) then
- write(0,*) 'packSendBuf2dReal: Not enough space in buffer to fit a single slice.'
+ write(0,*) 'packSendBuf3dReal: Not enough space in buffer', &
+ ' to fit a single slice.'
return
end if
@@ -1372,6 +1421,230 @@
end subroutine unpackRecvBuf2dInteger
+ subroutine unpackRecvBuf3dInteger(d1s, d1e, d2s, d2e, nField, field, recvList, startUnpackIdx, nBuffer, buffer, &
+ nUnpacked, lastUnpackedIdx)
+
+ implicit none
+
+ integer, intent(in) :: d1s, d1e, d2s, d2e, nField, nBuffer, startUnpackIdx
+ integer, dimension(d1s:d1e,d2s:d2e,*), intent(inout) :: field
+ type (exchange_list), intent(in) :: recvList
+ integer, dimension(nBuffer), intent(in) :: buffer
+ integer, intent(inout) :: nUnpacked, lastUnpackedIdx
+
+ integer :: i, j, k, n
+
+ n = (d1e-d1s+1) * (d2e-d2s+1)
+
+ nUnpacked = 0
+ do i=startUnpackIdx, recvList % nlist
+ nUnpacked = nUnpacked + n
+ if (nUnpacked > nBuffer) then
+ nUnpacked = nUnpacked - n
+ lastUnpackedIdx = i - 1
+ return
+ end if
+ k = nUnpacked-n+1
+ do j=d2s,d2e
+ field(d1s:d1e,j,recvList % list(i)) = buffer(k:k+d1e-d1s)
+ k = k + d1e-d1s+1
+ end do
+ end do
+ lastUnpackedIdx = recvList % nlist
+
+ end subroutine unpackRecvBuf3dInteger
+
+
+ subroutine dmpar_exch_halo_field1dInteger(dminfo, array, dim1, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1
+ integer, dimension(*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ allocate(recvListPtr % ibuffer(recvListPtr % nlist))
+ call MPI_Irecv(recvListPtr % ibuffer, recvListPtr % nlist, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ allocate(sendListPtr % ibuffer(sendListPtr % nlist))
+ call packSendBuf1dInteger(dim1, array, sendListPtr, 1, sendListPtr % nlist, sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, sendListPtr % nlist, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ call unpackRecvBuf1dInteger(dim1, array, recvListPtr, 1, recvListPtr % nlist, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field1dInteger
+
+
+ subroutine dmpar_exch_halo_field2dInteger(dminfo, array, dim1, dim2, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2
+ integer, dimension(dim1,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d2
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * recvListPtr % nlist
+ allocate(recvListPtr % ibuffer(d2))
+ call MPI_Irecv(recvListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d2 = dim1 * sendListPtr % nlist
+ allocate(sendListPtr % ibuffer(d2))
+ call packSendBuf2dInteger(1, dim1, dim2, array, sendListPtr, 1, d2, sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, d2, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d2 = dim1 * recvListPtr % nlist
+ call unpackRecvBuf2dInteger(1, dim1, dim2, array, recvListPtr, 1, d2, recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field2dInteger
+
+
+ subroutine dmpar_exch_halo_field3dInteger(dminfo, array, dim1, dim2, dim3, sendList, recvList)
+
+ implicit none
+
+ type (dm_info), intent(in) :: dminfo
+ integer, intent(in) :: dim1, dim2, dim3
+ integer, dimension(dim1,dim2,*), intent(inout) :: array
+ type (exchange_list), pointer :: sendList, recvList
+
+ type (exchange_list), pointer :: sendListPtr, recvListPtr
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: mpi_ierr
+ integer :: d3
+
+#ifdef _MPI
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ allocate(recvListPtr % ibuffer(d3))
+ call MPI_Irecv(recvListPtr % ibuffer, d3, MPI_INTEGERKIND, &
+ recvListPtr % procID, recvListPtr % procID, dminfo % comm, recvListPtr % reqID, mpi_ierr)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ d3 = dim1 * dim2 * sendListPtr % nlist
+ allocate(sendListPtr % ibuffer(d3))
+ call packSendBuf3dInteger(1, dim1, 1, dim2, dim3, array, sendListPtr, 1, d3, &
+ sendListPtr % ibuffer, nPacked, lastPackedIdx)
+ call MPI_Isend(sendListPtr % ibuffer, d3, MPI_INTEGERKIND, &
+ sendListPtr % procID, dminfo % my_proc_id, dminfo % comm, sendListPtr % reqID, mpi_ierr)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+ recvListPtr => recvList
+ do while (associated(recvListPtr))
+ if (recvListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(recvListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ d3 = dim1 * dim2 * recvListPtr % nlist
+ call unpackRecvBuf3dInteger(1, dim1, 1, dim2, dim3, array, recvListPtr, 1, d3, &
+ recvListPtr % ibuffer, nUnpacked, lastUnpackedIdx)
+ deallocate(recvListPtr % ibuffer)
+ end if
+ recvListPtr => recvListPtr % next
+ end do
+
+ sendListPtr => sendList
+ do while (associated(sendListPtr))
+ if (sendListPtr % procID /= dminfo % my_proc_id) then
+ call MPI_Wait(sendListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ deallocate(sendListPtr % ibuffer)
+ end if
+ sendListPtr => sendListPtr % next
+ end do
+
+#endif
+
+ end subroutine dmpar_exch_halo_field3dInteger
+
+
subroutine unpackRecvBuf1dReal(nField, field, recvList, startUnpackIdx, nBuffer, buffer, nUnpacked, lastUnpackedIdx)
implicit none
@@ -1651,5 +1924,5 @@
end subroutine dmpar_exch_halo_field3dReal
-
+
end module dmpar
Modified: branches/swmodel_del4/src/framework/module_grid_types.F
===================================================================
--- branches/swmodel_del4/src/framework/module_grid_types.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/framework/module_grid_types.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -4,8 +4,7 @@
integer, parameter :: nTimeLevs = 2
-#include "super_array_indices.inc"
-
+
! Derived type describing info for doing I/O specific to a field
type io_info
character (len=1024) :: fieldName
@@ -66,7 +65,7 @@
! Derived type for storing grid meta-data
- type grid_meta
+ type mesh_type
#include "field_dimensions.inc"
@@ -75,21 +74,12 @@
#include "time_invariant_fields.inc"
- end type grid_meta
+ end type mesh_type
- ! Derived type for storing model state
- type grid_state
+#include "variable_groups.inc"
-#include "time_varying_fields.inc"
- end type grid_state
-
- type grid_state_ptr
- type (grid_state), pointer :: state
- end type grid_state_ptr
-
-
! 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
@@ -105,11 +95,8 @@
type block_type
integer :: storageFactor ! Additional storage used by time integration scheme
- type (grid_meta), pointer :: mesh
- type (grid_state_ptr), pointer, dimension(:) :: time_levs
+#include "block_group_members.inc"
- type (grid_state), allocatable, dimension(:) :: intermediate_step
-
type (domain_type), pointer :: domain
type (parallel_info), pointer :: parinfo
@@ -170,60 +157,21 @@
nullify(b % prev)
nullify(b % next)
- allocate(b % time_levs(nTimeLevs))
-
- allocate(b % mesh)
- call allocate_grid_meta(b % mesh, &
-#include "dim_dummy_args.inc"
- )
-
- do i=1,nTimeLevs
- allocate(b % time_levs(i) % state)
- call allocate_grid_state(b % time_levs(i) % state, b)
- end do
-
key = 'STORAGE_FACTOR'
call mpas_query(key, b % storageFactor)
- ! Allocate storage for intermediate steps used by time integration scheme
- allocate(b % intermediate_step(b % storageFactor))
- do i=1,b % storageFactor
- call allocate_grid_state(b % intermediate_step(i), b)
- end do
-
allocate(b % parinfo)
b % domain => dom
+#include "block_allocs.inc"
+
end subroutine allocate_block
- subroutine allocate_grid_meta(g, &
-#include "dim_dummy_args.inc"
- )
+#include "group_alloc_routines.inc"
- implicit none
- type (grid_meta), intent(inout) :: g
-#include "dim_dummy_decls.inc"
-
-#include "grid_meta_allocs.inc"
-
- end subroutine allocate_grid_meta
-
-
- subroutine allocate_grid_state(s, b)
-
- implicit none
-
- type (grid_state), intent(inout) :: s
- type (block_type), pointer :: b
-
-#include "grid_state_allocs.inc"
-
- end subroutine allocate_grid_state
-
-
subroutine deallocate_domain(dom)
implicit none
@@ -251,78 +199,19 @@
integer :: i
- call deallocate_grid_meta(b % mesh)
- deallocate(b % mesh)
- do i=1,nTimeLevs
- call deallocate_grid_state(b % time_levs(i) % state)
- deallocate(b % time_levs(i) % state)
- end do
- deallocate(b % time_levs)
- do i=1,b % storageFactor
- call deallocate_grid_state(b % intermediate_step(i))
- end do
- deallocate(b % intermediate_step)
deallocate(b % parinfo)
+#include "block_deallocs.inc"
+
end subroutine deallocate_block
- subroutine deallocate_grid_meta(g)
+#include "group_dealloc_routines.inc"
- implicit none
- type (grid_meta), intent(inout) :: g
+#include "group_copy_routines.inc"
-#include "grid_meta_deallocs.inc"
- end subroutine deallocate_grid_meta
+#include "group_shift_level_routines.inc"
-
- subroutine deallocate_grid_state(s)
-
- implicit none
-
- type (grid_state), intent(inout) :: s
-
-#include "grid_state_deallocs.inc"
-
- end subroutine deallocate_grid_state
-
-
- subroutine copy_state(src, dest)
-
- implicit none
-
- type (grid_state), intent(in) :: src
- type (grid_state), intent(inout) :: dest
-
-#include "copy_state.inc"
-
- end subroutine copy_state
-
-
- subroutine shift_time_levels(domain)
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- integer :: i
- type (block_type), pointer :: block_ptr
- type (grid_state), pointer :: sptr
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
-
- sptr => block_ptr % time_levs(1) % state
- do i=1,nTimeLevs-1
- block_ptr % time_levs(i) % state => block_ptr % time_levs(i+1) % state
- end do
- block_ptr % time_levs(nTimeLevs) % state => sptr
-
- block_ptr => block_ptr % next
- end do
-
- end subroutine shift_time_levels
-
end module grid_types
Modified: branches/swmodel_del4/src/framework/module_io_input.F
===================================================================
--- branches/swmodel_del4/src/framework/module_io_input.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/framework/module_io_input.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -1093,13 +1093,6 @@
#include "netcdf_read_ids.inc"
-#ifdef EXPAND_LEVELS
- if (.not. config_do_restart) then
- input_obj % rdLocalnVertLevels = EXPAND_LEVELS
- write(0,*) 'Expanding nVertLevels to ',input_obj % rdLocalnVertLevels,' by duplicating the first level.'
- end if
-#endif
-
end subroutine io_input_init
@@ -1134,7 +1127,8 @@
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)
+ 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
@@ -1158,7 +1152,8 @@
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)
+ 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'
Modified: branches/swmodel_del4/src/framework/module_io_output.F
===================================================================
--- branches/swmodel_del4/src/framework/module_io_output.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/framework/module_io_output.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -337,7 +337,7 @@
type (io_output_object), intent(inout) :: output_obj
type (dm_info), intent(in) :: dminfo
- type (grid_meta), intent(in) :: mesh
+ type (mesh_type), intent(in) :: mesh
#include "dim_dummy_decls.inc"
integer :: nferr
Modified: branches/swmodel_del4/src/operators/module_RBF_interpolation.F
===================================================================
--- branches/swmodel_del4/src/operators/module_RBF_interpolation.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/operators/module_RBF_interpolation.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -112,7 +112,7 @@
implicit none
- type (grid_meta), intent(inout) :: grid
+ type (mesh_type), intent(inout) :: grid
integer :: nCells, nEdges
integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell
Modified: branches/swmodel_del4/src/operators/module_vector_reconstruction.F
===================================================================
--- branches/swmodel_del4/src/operators/module_vector_reconstruction.F 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/operators/module_vector_reconstruction.F 2010-10-22 19:14:07 UTC (rev 578)
@@ -23,7 +23,7 @@
implicit none
- type (grid_meta), intent(inout) :: grid
+ type (mesh_type), intent(inout) :: grid
! temporary arrays needed in the (to be constructed) init procedure
integer :: nCellsSolve
@@ -123,8 +123,8 @@
implicit none
- type (grid_state), intent(inout) :: state
- type (grid_meta), intent(in) :: grid
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
! temporary arrays needed in the compute procedure
integer :: nCellsSolve
Modified: branches/swmodel_del4/src/registry/gen_inc.c
===================================================================
--- branches/swmodel_del4/src/registry/gen_inc.c 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/registry/gen_inc.c 2010-10-22 19:14:07 UTC (rev 578)
@@ -150,12 +150,15 @@
}
-void gen_field_defs(struct variable * vars, struct dimension * dims)
+void gen_field_defs(struct group_list * groups, struct variable * vars, struct dimension * dims)
{
struct variable * var_ptr;
struct variable * var_ptr2;
+ struct variable_list * var_list_ptr;
+ struct variable_list * var_list_ptr2;
struct dimension * dim_ptr;
struct dimension_list * dimlist_ptr;
+ struct group_list * group_ptr;
FILE * fd;
char super_array[1024];
char array_class[1024];
@@ -163,59 +166,7 @@
int class_start, class_end;
int vtype;
- /*
- * Generate indices for super arrays
- */
- fd = fopen("super_array_indices.inc", "w");
- var_ptr = vars;
- memcpy(super_array, var_ptr->super_array, 1024);
- i = 1;
- while (var_ptr) {
- if (strncmp(super_array, var_ptr->super_array, 1024) != 0) {
- memcpy(super_array, var_ptr->super_array, 1024);
- i = 1;
- }
- if (strncmp(var_ptr->array_class, "-", 1024) != 0) fortprintf(fd, " integer :: index_%s = %i</font>
<font color="red">", var_ptr->name_in_code, i++);
- var_ptr = var_ptr->next;
- }
- var_ptr = vars;
- memcpy(super_array, var_ptr->super_array, 1024);
- memcpy(array_class, var_ptr->array_class, 1024);
- class_start = 1;
- class_end = 1;
- i = 1;
- while (var_ptr) {
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- if (strncmp(super_array, var_ptr->super_array, 1024) != 0) {
- if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = %i</font>
<font color="red">", array_class, class_end);
- if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = %i</font>
<font color="red">", super_array, i);
- class_start = 1;
- class_end = 1;
- i = 1;
- memcpy(super_array, var_ptr->super_array, 1024);
- memcpy(array_class, var_ptr->array_class, 1024);
- fortprintf(fd, " integer :: %s_start = %i</font>
<font color="red">", array_class, class_start);
- }
- else if (strncmp(array_class, var_ptr->array_class, 1024) != 0) {
- fortprintf(fd, " integer :: %s_end = %i</font>
<font color="red">", array_class, class_end);
- class_start = class_end+1;
- class_end = class_start;
- memcpy(array_class, var_ptr->array_class, 1024);
- fortprintf(fd, " integer :: %s_start = %i</font>
<font color="red">", array_class, class_start);
- i++;
- }
- else {
- class_end++;
- i++;
- }
- }
- var_ptr = var_ptr->next;
- }
- if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = %i</font>
<font color="red">", array_class, class_end);
- if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = %i</font>
<font color="gray">", super_array, i);
- fclose(fd);
-
/*
* Generate declarations of dimensions
*/
@@ -311,101 +262,295 @@
/*
- * Generate declarations of time-invariant fields
+ * Generate declarations of mesh group
*/
fd = fopen("time_invariant_fields.inc", "w");
- var_ptr = vars;
- while (var_ptr) {
- if (var_ptr->timedim == 0) {
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- memcpy(super_array, var_ptr->super_array, 1024);
- memcpy(array_class, var_ptr->array_class, 1024);
- vtype = var_ptr->vtype;
- while (var_ptr && strncmp(super_array, var_ptr->super_array, 1024) == 0) {
- var_ptr2 = var_ptr;
- var_ptr = var_ptr->next;
+ group_ptr = groups;
+ while (group_ptr) {
+
+ if (!strncmp(group_ptr->name, "mesh", 1024)) {
+
+ var_list_ptr = group_ptr->vlist;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ i = 1;
+ while (var_list_ptr) {
+ if (strncmp(super_array, var_list_ptr->var->super_array, 1024) != 0) {
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ i = 1;
+ }
+ if (strncmp(var_list_ptr->var->array_class, "-", 1024) != 0) fortprintf(fd, " integer :: index_%s = %i</font>
<font color="blue">", var_list_ptr->var->name_in_code, i++);
+ var_list_ptr = var_list_ptr->next;
+ }
+
+ var_list_ptr = group_ptr->vlist;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ class_start = 1;
+ class_end = 1;
+ i = 1;
+ while (var_list_ptr) {
+ if (strncmp(var_list_ptr->var->super_array, "-", 1024) != 0) {
+ if (strncmp(super_array, var_list_ptr->var->super_array, 1024) != 0) {
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = %i</font>
<font color="blue">", super_array, i);
+ class_start = 1;
+ class_end = 1;
+ i = 1;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ fortprintf(fd, " integer :: %s_start = %i</font>
<font color="blue">", array_class, class_start);
+ }
+ else if (strncmp(array_class, var_list_ptr->var->array_class, 1024) != 0) {
+ fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ class_start = class_end+1;
+ class_end = class_start;
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ fortprintf(fd, " integer :: %s_start = %i</font>
<font color="red">", array_class, class_start);
+ i++;
+ }
+ else {
+ class_end++;
+ i++;
+ }
}
- if (vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="red">", (var_ptr2->ndims)+1, var_ptr2->super_array);
- if (vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="red">", (var_ptr2->ndims)+1, var_ptr2->super_array);
+ var_list_ptr = var_list_ptr->next;
}
- else {
- if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="red">", var_ptr->ndims, var_ptr->name_in_code);
- if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="red">", var_ptr->ndims, var_ptr->name_in_code);
- var_ptr = var_ptr->next;
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = %i</font>
<font color="blue">", super_array, i);
+
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+ if (!strncmp(var_ptr->super_array, "-", 1024)) {
+ if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="blue">", var_ptr->ndims, var_ptr->name_in_code);
+ if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="blue">", var_ptr->ndims, var_ptr->name_in_code);
+ }
+ else {
+ if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="blue">", var_ptr->ndims+1, var_ptr->super_array);
+ if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="red">", var_ptr->ndims+1, var_ptr->super_array);
+ while (var_list_ptr->next && !strncmp(var_list_ptr->next->var->super_array, var_list_ptr->var->super_array, 1024)) var_list_ptr = var_list_ptr->next;
+ }
+ var_list_ptr = var_list_ptr->next;
}
+ break;
}
- else
- var_ptr = var_ptr->next;
+ group_ptr = group_ptr->next;
}
fclose(fd);
/*
- * Generate declarations of time-invariant fields
+ * Generate declarations of non-mesh groups
*/
- fd = fopen("time_varying_fields.inc", "w");
- var_ptr = vars;
- while (var_ptr) {
- if (var_ptr->timedim == 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);
- vtype = var_ptr->vtype;
- while (var_ptr && strncmp(super_array, var_ptr->super_array, 1024) == 0) {
- var_ptr2 = var_ptr;
- var_ptr = var_ptr->next;
+ fd = fopen("variable_groups.inc", "w");
+
+ group_ptr = groups;
+ while (group_ptr) {
+ if (strncmp(group_ptr->name, "mesh", 1024)) {
+ fortprintf(fd, " type %s_type</font>
<font color="blue">", group_ptr->name);
+
+ var_list_ptr = group_ptr->vlist;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ i = 1;
+ while (var_list_ptr) {
+ if (strncmp(super_array, var_list_ptr->var->super_array, 1024) != 0) {
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ i = 1;
+ }
+ if (strncmp(var_list_ptr->var->array_class, "-", 1024) != 0) fortprintf(fd, " integer :: index_%s = %i</font>
<font color="blue">", var_list_ptr->var->name_in_code, i++);
+ var_list_ptr = var_list_ptr->next;
+ }
+
+ var_list_ptr = group_ptr->vlist;
+ sprintf(super_array, "-");
+ sprintf(array_class, "-");
+ class_start = 1;
+ class_end = 1;
+ i = 1;
+
+ while (var_list_ptr) {
+
+ /* Is the current variable in a super array? */
+ if (strncmp(var_list_ptr->var->super_array, "-", 1024) != 0) {
+
+ /* Have we hit the beginning of a new super array? */
+ if (strncmp(super_array, var_list_ptr->var->super_array, 1024) != 0) {
+ /* Finish off the previous super array? */
+ if (strncmp(super_array, "-", 1024) != 0) {
+ fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ fortprintf(fd, " integer :: num_%s = %i</font>
<font color="blue">", super_array, i);
+ }
+ class_start = 1;
+ class_end = 1;
+ i = 1;
+ memcpy(super_array, var_list_ptr->var->super_array, 1024);
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ fortprintf(fd, " integer :: %s_start = %i</font>
<font color="blue">", array_class, class_start);
+ }
+ /* Or have we hit the beginning of a new array class? */
+ else if (strncmp(array_class, var_list_ptr->var->array_class, 1024) != 0) {
+ fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ class_start = class_end+1;
+ class_end = class_start;
+ memcpy(array_class, var_list_ptr->var->array_class, 1024);
+ fortprintf(fd, " integer :: %s_start = %i</font>
<font color="red">", array_class, class_start);
+ i++;
+ }
+ else {
+ class_end++;
+ i++;
+ }
+
}
- if (vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="red">", (var_ptr2->ndims)+1, var_ptr2->super_array);
- if (vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="red">", (var_ptr2->ndims)+1, var_ptr2->super_array);
+ var_list_ptr = var_list_ptr->next;
+
}
- else {
- if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="red">", var_ptr->ndims, var_ptr->name_in_code);
- if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="red">", var_ptr->ndims, var_ptr->name_in_code);
- var_ptr = var_ptr->next;
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = %i</font>
<font color="blue">", array_class, class_end);
+ if (strncmp(super_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = %i</font>
<font color="blue">", super_array, i);
+
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
+ if (!strncmp(var_ptr->super_array, "-", 1024)) {
+ if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="blue">", var_ptr->ndims, var_ptr->name_in_code);
+ if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="blue">", var_ptr->ndims, var_ptr->name_in_code);
+ }
+ else {
+ if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s</font>
<font color="blue">", var_ptr->ndims+1, var_ptr->super_array);
+ if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s</font>
<font color="blue">", var_ptr->ndims+1, var_ptr->super_array);
+ while (var_list_ptr->next && !strncmp(var_list_ptr->next->var->super_array, var_list_ptr->var->super_array, 1024)) var_list_ptr = var_list_ptr->next;
+ }
+ var_list_ptr = var_list_ptr->next;
}
+
+ fortprintf(fd, " end type %s_type</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+
+ if (group_ptr->vlist->var->ntime_levs > 1) {
+ fortprintf(fd, " type %s_pointer_type</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " type (%s_type), pointer :: %s </font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " end type %s_pointer_type</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+
+ fortprintf(fd, " type %s_multilevel_type</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " integer :: nTimeLevels</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_pointer_type), dimension(:), pointer :: time_levs</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " end type %s_multilevel_type</font>
<font color="black"></font>
<font color="black"></font>
<font color="red">", group_ptr->name);
+ }
+
}
- else
- var_ptr = var_ptr->next;
+ group_ptr = group_ptr->next;
}
fclose(fd);
-
/*
- * Generate grid metadata allocations
+ * Generate instantiations of variable groups in block_type
*/
- fd = fopen("grid_meta_allocs.inc", "w");
+ fd = fopen("block_group_members.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, " g %% %s = %s</font>
<font color="red">", dim_ptr->name_in_code, dim_ptr->name_in_code);
- if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " g %% %s = %s</font>
<font color="red">", dim_ptr->name_in_file, dim_ptr->name_in_file);
- dim_ptr = dim_ptr->next;
+ group_ptr = groups;
+ while (group_ptr) {
+ if (group_ptr->vlist->var->ntime_levs > 1)
+ fortprintf(fd, " type (%s_multilevel_type), pointer :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ else
+ fortprintf(fd, " type (%s_type), pointer :: %s</font>
<font color="red">", group_ptr->name, group_ptr->name);
+ group_ptr = group_ptr->next;
}
- fortprintf(fd, "</font>
<font color="red">");
- var_ptr = vars;
- while (var_ptr) {
- if (var_ptr->timedim == 0) {
+ fclose(fd);
+
+
+ /* To be included in allocate_block */
+ fd = fopen("block_allocs.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ fortprintf(fd, " allocate(b %% %s)</font>
<font color="blue">", group_ptr->name);
+ if (group_ptr->vlist->var->ntime_levs > 1) {
+ fortprintf(fd, " b %% %s %% nTimeLevels = %i</font>
<font color="blue">", group_ptr->name, group_ptr->vlist->var->ntime_levs);
+ fortprintf(fd, " allocate(b %% %s %% time_levs(%i))</font>
<font color="blue">", group_ptr->name, group_ptr->vlist->var->ntime_levs);
+ fortprintf(fd, " do i=1,b %% %s %% nTimeLevels</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " allocate(b %% %s %% time_levs(i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " call allocate_%s(b %% %s %% time_levs(i) %% %s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="blue">");
+ fortprintf(fd, " )</font>
<font color="blue">");
+ fortprintf(fd, " end do</font>
<font color="black"></font>
<font color="blue">");
+ }
+ else {
+ fortprintf(fd, " call allocate_%s(b %% %s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="blue">");
+ fortprintf(fd, " )</font>
<font color="black"></font>
<font color="blue">");
+ }
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
+
+
+ /* To be included in deallocate_block */
+ fd = fopen("block_deallocs.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ if (group_ptr->vlist->var->ntime_levs > 1) {
+ fortprintf(fd, " do i=1,b %% %s %% nTimeLevels</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " call deallocate_%s(b %% %s %% time_levs(i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, " deallocate(b %% %s %% time_levs(i) %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " end do</font>
<font color="blue">");
+ fortprintf(fd, " deallocate(b %% %s %% time_levs)</font>
<font color="blue">", group_ptr->name);
+ }
+ else {
+ fortprintf(fd, " call deallocate_%s(b %% %s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ }
+ fortprintf(fd, " deallocate(b %% %s)</font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ group_ptr = group_ptr->next;
+ }
+ fclose(fd);
+
+ /* Definitions of allocate subroutines */
+ fd = fopen("group_alloc_routines.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ fortprintf(fd, " subroutine allocate_%s(%s, &</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "#include \"dim_dummy_args.inc\"</font>
<font color="blue">");
+ fortprintf(fd, " )</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), intent(inout) :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "#include \"dim_dummy_decls.inc\"</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+
+ if (!strncmp(group_ptr->name, "mesh", 1024)) {
+ 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, " %s %% %s = %s</font>
<font color="blue">", group_ptr->name, dim_ptr->name_in_code, dim_ptr->name_in_code);
+ 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="red">");
+ }
+
+
+ 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);
- vtype = var_ptr->vtype;
i = 0;
- while (var_ptr && strncmp(super_array, var_ptr->super_array, 1024) == 0) {
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
i++;
- var_ptr2 = var_ptr;
- var_ptr = var_ptr->next;
+ var_list_ptr2 = var_list_ptr;
+ var_list_ptr = var_list_ptr->next;
}
- fortprintf(fd, " allocate(g %% %s)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " allocate(g %% %s %% ioinfo)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " allocate(g %% %s %% array(%i, ", var_ptr2->super_array, i);
+ var_ptr2 = var_list_ptr2->var;
+ fortprintf(fd, " allocate(%s %% %s)</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array);
+ fortprintf(fd, " allocate(%s %% %s %% ioinfo)</font>
<font color="gray">", group_ptr->name, var_ptr2->super_array);
+ 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) ||
!strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
!strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
- fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_code);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_file);
else
if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s", dimlist_ptr->dim->name_in_file);
else fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
@@ -414,41 +559,43 @@
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))
- fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_code);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_file);
else
if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_file);
else fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
dimlist_ptr = dimlist_ptr->next;
}
fortprintf(fd, "))</font>
<font color="red">");
- fortprintf(fd, " g %% %s %% array = 0</font>
<font color="blue">", var_ptr2->super_array ); /* initialize field to zero */
+ fortprintf(fd, " %s %% %s %% array = 0</font>
<font color="red">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
if (var_ptr2->iostreams & INPUT0)
- fortprintf(fd, " g %% %s %% ioinfo %% input = .true.</font>
<font color="blue">", var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% ioinfo %% input = .true.</font>
<font color="red">", group_ptr->name, var_ptr2->super_array);
else
- fortprintf(fd, " g %% %s %% ioinfo %% input = .false.</font>
<font color="blue">", var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% ioinfo %% input = .false.</font>
<font color="red">", group_ptr->name, var_ptr2->super_array);
if (var_ptr2->iostreams & RESTART0)
- fortprintf(fd, " g %% %s %% ioinfo %% restart = .true.</font>
<font color="blue">", var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% ioinfo %% restart = .true.</font>
<font color="red">", group_ptr->name, var_ptr2->super_array);
else
- fortprintf(fd, " g %% %s %% ioinfo %% restart = .false.</font>
<font color="blue">", var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% ioinfo %% restart = .false.</font>
<font color="red">", group_ptr->name, var_ptr2->super_array);
if (var_ptr2->iostreams & OUTPUT0)
- fortprintf(fd, " g %% %s %% ioinfo %% output = .true.</font>
<font color="blue">", var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% ioinfo %% output = .true.</font>
<font color="red">", group_ptr->name, var_ptr2->super_array);
else
- fortprintf(fd, " g %% %s %% ioinfo %% output = .false.</font>
<font color="blue">", var_ptr2->super_array);
+ fortprintf(fd, " %s %% %s %% ioinfo %% output = .false.</font>
<font color="black">", group_ptr->name, var_ptr2->super_array);
fortprintf(fd, "</font>
<font color="red">");
}
else {
- fortprintf(fd, " allocate(g %% %s)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " allocate(g %% %s %% ioinfo)</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " allocate(%s %% %s)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " allocate(%s %% %s %% ioinfo)</font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code);
if (var_ptr->ndims > 0) {
- fortprintf(fd, " allocate(g %% %s %% array(", var_ptr->name_in_code);
+ fortprintf(fd, " allocate(%s %% %s %% array(", group_ptr->name, var_ptr->name_in_code);
dimlist_ptr = var_ptr->dimlist;
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))
- fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_code);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "%s + 1", dimlist_ptr->dim->name_in_file);
else
if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s", dimlist_ptr->dim->name_in_file);
else fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
@@ -457,313 +604,112 @@
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))
- fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_code);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", %s + 1", dimlist_ptr->dim->name_in_file);
else
if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_file);
else fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
dimlist_ptr = dimlist_ptr->next;
}
fortprintf(fd, "))</font>
<font color="red">");
- fortprintf(fd, " g %% %s %% array = 0</font>
<font color="blue">", var_ptr->name_in_code ); /* initialize field to zero */
+ fortprintf(fd, " %s %% %s %% array = 0</font>
<font color="red">", group_ptr->name, var_ptr->name_in_code ); /* initialize field to zero */
}
if (var_ptr->iostreams & INPUT0)
- fortprintf(fd, " g %% %s %% ioinfo %% input = .true.</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% ioinfo %% input = .true.</font>
<font color="red">", group_ptr->name, var_ptr->name_in_code);
else
- fortprintf(fd, " g %% %s %% ioinfo %% input = .false.</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% ioinfo %% input = .false.</font>
<font color="red">", group_ptr->name, var_ptr->name_in_code);
if (var_ptr->iostreams & RESTART0)
- fortprintf(fd, " g %% %s %% ioinfo %% restart = .true.</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% ioinfo %% restart = .true.</font>
<font color="red">", group_ptr->name, var_ptr->name_in_code);
else
- fortprintf(fd, " g %% %s %% ioinfo %% restart = .false.</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% ioinfo %% restart = .false.</font>
<font color="red">", group_ptr->name, var_ptr->name_in_code);
if (var_ptr->iostreams & OUTPUT0)
- fortprintf(fd, " g %% %s %% ioinfo %% output = .true.</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% ioinfo %% output = .true.</font>
<font color="red">", group_ptr->name, var_ptr->name_in_code);
else
- fortprintf(fd, " g %% %s %% ioinfo %% output = .false.</font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " %s %% %s %% ioinfo %% output = .false.</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, "</font>
<font color="red">");
- var_ptr = var_ptr->next;
+ var_list_ptr = var_list_ptr->next;
}
}
- else
- var_ptr = var_ptr->next;
- }
+ fortprintf(fd, " end subroutine allocate_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ group_ptr = group_ptr->next;
+ }
fclose(fd);
+
+ /* Definitions of deallocate subroutines */
+ fd = fopen("group_dealloc_routines.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ fortprintf(fd, " subroutine deallocate_%s(%s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), intent(inout) :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="red">");
-
- /*
- * Generate grid metadata deallocations
- */
- fd = fopen("grid_meta_deallocs.inc", "w");
-
- var_ptr = vars;
- while (var_ptr) {
- if (var_ptr->timedim == 0) {
+ 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);
- vtype = var_ptr->vtype;
i = 0;
- while (var_ptr && strncmp(super_array, var_ptr->super_array, 1024) == 0) {
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
i++;
- var_ptr2 = var_ptr;
- var_ptr = var_ptr->next;
+ var_list_ptr2 = var_list_ptr;
+ var_list_ptr = var_list_ptr->next;
}
- fortprintf(fd, " deallocate(g %% %s %% array)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " deallocate(g %% %s %% ioinfo)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " deallocate(g %% %s)</font>
<font color="black"></font>
<font color="blue">", var_ptr2->super_array);
+ fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="blue">", 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, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="red">", group_ptr->name, var_list_ptr2->var->super_array);
}
else {
if (var_ptr->ndims > 0) {
- fortprintf(fd, " deallocate(g %% %s %% array)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " deallocate(g %% %s %% ioinfo)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " deallocate(g %% %s)</font>
<font color="black"></font>
<font color="blue">", var_ptr->name_in_code);
+ fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="blue">", 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, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="red">", group_ptr->name, var_ptr->name_in_code);
}
else {
- fortprintf(fd, " deallocate(g %% %s %% ioinfo)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " deallocate(g %% %s)</font>
<font color="black"></font>
<font color="blue">", 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, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="red">", group_ptr->name, var_ptr->name_in_code);
}
- var_ptr = var_ptr->next;
+ var_list_ptr = var_list_ptr->next;
}
}
- else
- var_ptr = var_ptr->next;
- }
- fclose(fd);
-
-
- /*
- * Generate grid state allocations
- */
- fd = fopen("grid_state_allocs.inc", "w");
-
- var_ptr = vars;
- while (var_ptr) {
- if (var_ptr->timedim == 1 && var_ptr->ndims > 0) {
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- memcpy(super_array, var_ptr->super_array, 1024);
- memcpy(array_class, var_ptr->array_class, 1024);
- vtype = var_ptr->vtype;
- i = 0;
- while (var_ptr && strncmp(super_array, var_ptr->super_array, 1024) == 0) {
- i++;
- var_ptr2 = var_ptr;
- var_ptr = var_ptr->next;
- }
- fortprintf(fd, " allocate(s %% %s)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " allocate(s %% %s %% ioinfo)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " allocate(s %% %s %% array(%i, ", var_ptr2->super_array, i);
- dimlist_ptr = var_ptr2->dimlist;
- 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))
- fortprintf(fd, "b %% mesh %% %s + 1", dimlist_ptr->dim->name_in_code);
- else
- if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- dimlist_ptr = dimlist_ptr->next;
- 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))
- fortprintf(fd, ", b %% mesh %% %s + 1", dimlist_ptr->dim->name_in_code);
- else
- if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- dimlist_ptr = dimlist_ptr->next;
- }
- fortprintf(fd, "))</font>
<font color="red">");
- fortprintf(fd, " s %% %s %% block => b</font>
<font color="red">", var_ptr2->super_array);
-
- if (var_ptr2->iostreams & INPUT0)
- fortprintf(fd, " s %% %s %% ioinfo %% input = .true.</font>
<font color="red">", var_ptr2->super_array);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% input = .false.</font>
<font color="red">", var_ptr2->super_array);
-
- if (var_ptr2->iostreams & RESTART0)
- fortprintf(fd, " s %% %s %% ioinfo %% restart = .true.</font>
<font color="red">", var_ptr2->super_array);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% restart = .false.</font>
<font color="red">", var_ptr2->super_array);
-
- if (var_ptr2->iostreams & OUTPUT0)
- fortprintf(fd, " s %% %s %% ioinfo %% output = .true.</font>
<font color="red">", var_ptr2->super_array);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% output = .false.</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, "</font>
<font color="red">");
- }
- else {
- fortprintf(fd, " allocate(s %% %s)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " allocate(s %% %s %% ioinfo)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " allocate(s %% %s %% array(", var_ptr->name_in_code);
- dimlist_ptr = var_ptr->dimlist;
- if (dimlist_ptr->dim->constant_value < 0) {
- 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))
- fortprintf(fd, "b %% mesh %% %s + 1", dimlist_ptr->dim->name_in_code);
- else
- if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else fortprintf(fd, "b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- }
- else {
- fortprintf(fd, "%i", dimlist_ptr->dim->constant_value);
- }
- dimlist_ptr = dimlist_ptr->next;
- while (dimlist_ptr) {
- if (dimlist_ptr->dim->constant_value < 0) {
- 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))
- fortprintf(fd, ", b %% mesh %% %s + 1", dimlist_ptr->dim->name_in_code);
- else
- if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else fortprintf(fd, ", b %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- }
- else {
- fortprintf(fd, ", %i", dimlist_ptr->dim->constant_value);
- }
- dimlist_ptr = dimlist_ptr->next;
- }
- fortprintf(fd, "))</font>
<font color="red">");
- fortprintf(fd, " s %% %s %% block => b</font>
<font color="red">", var_ptr->name_in_code);
-
- if (var_ptr->iostreams & INPUT0)
- fortprintf(fd, " s %% %s %% ioinfo %% input = .true.</font>
<font color="red">", var_ptr->name_in_code);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% input = .false.</font>
<font color="red">", var_ptr->name_in_code);
-
- if (var_ptr->iostreams & RESTART0)
- fortprintf(fd, " s %% %s %% ioinfo %% restart = .true.</font>
<font color="red">", var_ptr->name_in_code);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% restart = .false.</font>
<font color="red">", var_ptr->name_in_code);
-
- if (var_ptr->iostreams & OUTPUT0)
- fortprintf(fd, " s %% %s %% ioinfo %% output = .true.</font>
<font color="red">", var_ptr->name_in_code);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% output = .false.</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, "</font>
<font color="red">");
- var_ptr = var_ptr->next;
- }
- }
- else if (var_ptr->timedim == 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);
- vtype = var_ptr->vtype;
- i = 0;
- while (var_ptr && strncmp(super_array, var_ptr->super_array, 1024) == 0) {
- i++;
- var_ptr2 = var_ptr;
- var_ptr = var_ptr->next;
- }
- fortprintf(fd, " allocate(s %% %s)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " allocate(s %% %s %% ioinfo)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " allocate(s %% %s %% array(%i)", var_ptr->name_in_code, i);
- fortprintf(fd, " s %% %s %% block => b</font>
<font color="red">", var_ptr2->super_array);
-
- if (var_ptr2->iostreams & INPUT0)
- fortprintf(fd, " s %% %s %% ioinfo %% input = .true.</font>
<font color="red">", var_ptr2->super_array);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% input = .false.</font>
<font color="red">", var_ptr2->super_array);
-
- if (var_ptr2->iostreams & RESTART0)
- fortprintf(fd, " s %% %s %% ioinfo %% restart = .true.</font>
<font color="red">", var_ptr2->super_array);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% restart = .false.</font>
<font color="red">", var_ptr2->super_array);
-
- if (var_ptr2->iostreams & OUTPUT0)
- fortprintf(fd, " s %% %s %% ioinfo %% output = .true.</font>
<font color="red">", var_ptr2->super_array);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% output = .false.</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, "</font>
<font color="red">");
- }
- else {
- fortprintf(fd, " allocate(s %% %s)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " allocate(s %% %s %% ioinfo)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " s %% %s %% block => b</font>
<font color="red">", var_ptr->name_in_code);
-
- if (var_ptr->iostreams & INPUT0)
- fortprintf(fd, " s %% %s %% ioinfo %% input = .true.</font>
<font color="red">", var_ptr->name_in_code);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% input = .false.</font>
<font color="red">", var_ptr->name_in_code);
-
- if (var_ptr->iostreams & RESTART0)
- fortprintf(fd, " s %% %s %% ioinfo %% restart = .true.</font>
<font color="red">", var_ptr->name_in_code);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% restart = .false.</font>
<font color="red">", var_ptr->name_in_code);
-
- if (var_ptr->iostreams & OUTPUT0)
- fortprintf(fd, " s %% %s %% ioinfo %% output = .true.</font>
<font color="red">", var_ptr->name_in_code);
- else
- fortprintf(fd, " s %% %s %% ioinfo %% output = .false.</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, "</font>
<font color="red">");
- var_ptr = var_ptr->next;
- }
- }
- else
- var_ptr = var_ptr->next;
+ fortprintf(fd, " end subroutine deallocate_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="red">", group_ptr->name);
+ group_ptr = group_ptr->next;
}
-
fclose(fd);
-
- /*
- * Generate grid state deallocations
- */
- fd = fopen("grid_state_deallocs.inc", "w");
-
- var_ptr = vars;
- while (var_ptr) {
- if (var_ptr->timedim == 1) {
+ /* Definitions of copy subroutines */
+ fd = fopen("group_copy_routines.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ fortprintf(fd, " subroutine copy_%s(dest, src)</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), intent(in) :: src</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " type (%s_type), intent(inout) :: dest</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, "</font>
<font color="red">");
+ 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);
- vtype = var_ptr->vtype;
i = 0;
- while (var_ptr && strncmp(super_array, var_ptr->super_array, 1024) == 0) {
+ while (var_list_ptr && strncmp(super_array, var_list_ptr->var->super_array, 1024) == 0) {
i++;
- var_ptr2 = var_ptr;
- var_ptr = var_ptr->next;
+ var_list_ptr2 = var_list_ptr;
+ var_list_ptr = var_list_ptr->next;
}
- fortprintf(fd, " deallocate(s %% %s %% array)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " deallocate(s %% %s %% ioinfo)</font>
<font color="red">", var_ptr2->super_array);
- fortprintf(fd, " deallocate(s %% %s)</font>
<font color="black"></font>
<font color="red">", var_ptr2->super_array);
- }
- else {
- if (var_ptr->ndims > 0) fortprintf(fd, " deallocate(s %% %s %% array)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " deallocate(s %% %s %% ioinfo)</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " deallocate(s %% %s)</font>
<font color="black"></font>
<font color="red">", var_ptr->name_in_code);
- var_ptr = var_ptr->next;
- }
- }
- else
- var_ptr = var_ptr->next;
- }
-
- fclose(fd);
-
-
- /*
- * Generate copies of state arrays
- */
- fd = fopen("copy_state.inc", "w");
-
- var_ptr = vars;
- while (var_ptr) {
- if (var_ptr->timedim == 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);
- vtype = var_ptr->vtype;
- i = 0;
- while (var_ptr && strncmp(super_array, var_ptr->super_array, 1024) == 0) {
- i++;
- var_ptr2 = var_ptr;
- var_ptr = var_ptr->next;
- }
+ var_ptr2 = var_list_ptr2->var;
if (var_ptr2->ndims > 0)
fortprintf(fd, " dest %% %s %% array = src %% %s %% array</font>
<font color="gray">", var_ptr2->super_array, var_ptr2->super_array);
else
@@ -774,30 +720,59 @@
fortprintf(fd, " dest %% %s %% array = src %% %s %% array</font>
<font color="black">", var_ptr->name_in_code, var_ptr->name_in_code);
else
fortprintf(fd, " dest %% %s %% scalar = src %% %s %% scalar</font>
<font color="red">", var_ptr->name_in_code, var_ptr->name_in_code);
- var_ptr = var_ptr->next;
+ var_list_ptr = var_list_ptr->next;
}
}
- else
- var_ptr = var_ptr->next;
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " end subroutine copy_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="blue">", group_ptr->name);
+ group_ptr = group_ptr->next;
}
+ fclose(fd);
+ /* Definitions of shift_time_level subroutines */
+ fd = fopen("group_shift_level_routines.inc", "w");
+ group_ptr = groups;
+ while (group_ptr) {
+ if (group_ptr->vlist->var->ntime_levs > 1) {
+ fortprintf(fd, " subroutine shift_time_levels_%s(%s)</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " implicit none</font>
<font color="blue">");
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_multilevel_type), intent(inout) :: %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " integer :: i</font>
<font color="blue">");
+ fortprintf(fd, " type (%s_type), pointer :: sptr</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " sptr => %s %% time_levs(1) %% %s</font>
<font color="blue">", group_ptr->name, group_ptr->name);
+ fortprintf(fd, " do i=1,%s %% nTimeLevels-1</font>
<font color="blue">", group_ptr->name);
+ fortprintf(fd, " %s %% time_levs(i) %% %s => %s %% time_levs(i+1) %% %s</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, " end do</font>
<font color="blue">");
+ fortprintf(fd, " %s %% time_levs(%s %% nTimeLevels) %% %s => sptr</font>
<font color="blue">", group_ptr->name, group_ptr->name, group_ptr->name);
+ fortprintf(fd, "</font>
<font color="blue">");
+ fortprintf(fd, " end subroutine shift_time_levels_%s</font>
<font color="black"></font>
<font color="black"></font>
<font color="gray">", group_ptr->name);
+ }
+ group_ptr = group_ptr->next;
+ }
fclose(fd);
+
}
-void gen_reads(struct variable * vars, struct dimension * dims)
+void gen_reads(struct group_list * groups, struct variable * vars, struct dimension * dims)
{
struct variable * var_ptr;
+ struct variable_list * var_list_ptr;
struct dimension * dim_ptr;
struct dimension_list * dimlist_ptr, * lastdim;
+ struct group_list * group_ptr;
struct dtable * dictionary;
FILE * fd;
char vtype[5];
char fname[32];
+ char struct_deref[1024];
char * cp1, * cp2;
int i, j;
int ivtype;
- int has_vert_dim, vert_dim;
/*
@@ -835,124 +810,64 @@
*/
fd = fopen("io_input_fields.inc", "w");
- var_ptr = vars;
- while (var_ptr) {
- i = 1;
- dimlist_ptr = var_ptr->dimlist;
- if (var_ptr->vtype == INTEGER) sprintf(vtype, "int");
- else if (var_ptr->vtype == REAL) sprintf(vtype, "real");
+ group_ptr = groups;
+ while (group_ptr) {
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- if (var_ptr->timedim) {
- fortprintf(fd, " if ((block %% time_levs(1) %% state %% %s %% ioinfo %% input .and. .not. config_do_restart) .or. &</font>
<font color="red">", var_ptr->super_array);
- fortprintf(fd, " (block %% time_levs(1) %% state %% %s %% ioinfo %% restart .and. config_do_restart)) then</font>
<font color="red">", var_ptr->super_array);
- }
- else {
- fortprintf(fd, " if ((block %% mesh %% %s %% ioinfo %% input .and. .not. config_do_restart) .or. &</font>
<font color="red">", var_ptr->super_array);
- fortprintf(fd, " (block %% mesh %% %s %% ioinfo %% restart .and. config_do_restart)) then</font>
<font color="red">", var_ptr->super_array);
- }
- }
- else {
- if (var_ptr->timedim) {
- fortprintf(fd, " if ((block %% time_levs(1) %% state %% %s %% ioinfo %% input .and. .not. config_do_restart) .or. &</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " (block %% time_levs(1) %% state %% %s %% ioinfo %% restart .and. config_do_restart)) then</font>
<font color="red">", var_ptr->name_in_code);
- }
- else {
- fortprintf(fd, " if ((block %% mesh %% %s %% ioinfo %% input .and. .not. config_do_restart) .or. &</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " (block %% mesh %% %s %% ioinfo %% restart .and. config_do_restart)) then</font>
<font color="red">", var_ptr->name_in_code);
- }
- }
- vert_dim = 0;
- while (dimlist_ptr) {
- if (i < var_ptr->ndims) {
- has_vert_dim = !strcmp( "nVertLevels", dimlist_ptr->dim->name_in_code);
- fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="red">", vtype, var_ptr->ndims, i);
- if (has_vert_dim) {
- vert_dim = i;
- fortprintf(fd, "#ifdef EXPAND_LEVELS</font>
<font color="red">");
- fortprintf(fd, " if (.not. config_do_restart) then</font>
<font color="red">");
- fortprintf(fd, " %s%id %% ioinfo %% count(%i) = 1</font>
<font color="red">", vtype, var_ptr->ndims, i);
- fortprintf(fd, " else</font>
<font color="red">");
- fortprintf(fd, "#endif</font>
<font color="red">");
- }
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " %s%id %% ioinfo %% count(%i) = block %% mesh %% %s</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, " %s%id %% ioinfo %% count(%i) = block %% mesh %% %s</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %s</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
- if (has_vert_dim) {
- fortprintf(fd, "#ifdef EXPAND_LEVELS</font>
<font color="red">");
- fortprintf(fd, " end if</font>
<font color="red">");
- fortprintf(fd, "#endif</font>
<font color="red">");
- }
- }
- else {
- if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
- split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, " %s%id %% ioinfo %% start(%i) = read%sStart</font>
<font color="red">", vtype, var_ptr->ndims, i, cp1);
- fortprintf(fd, " %s%id %% ioinfo %% count(%i) = read%sCount%s</font>
<font color="red">", vtype, var_ptr->ndims, i, cp1, cp2);
- free(cp1);
- free(cp2);
- }
- else {
- fortprintf(fd, " %s%id %% ioinfo %% start(%i) = read%sStart</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code+1);
- fortprintf(fd, " %s%id %% ioinfo %% count(%i) = read%sCount</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code+1);
- }
- }
- dimlist_ptr = dimlist_ptr->next;
- i++;
- }
+ if (group_ptr->vlist->var->ntime_levs > 1)
+ snprintf(struct_deref, 1024, "block %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name);
+ else
+ snprintf(struct_deref, 1024, "block %% %s", group_ptr->name);
- if (var_ptr->ndims > 0) {
- fortprintf(fd, " allocate(%s%id %% array(", vtype, var_ptr->ndims);
i = 1;
dimlist_ptr = var_ptr->dimlist;
+ if (var_ptr->vtype == INTEGER) sprintf(vtype, "int");
+ else if (var_ptr->vtype == REAL) sprintf(vtype, "real");
- if (i < var_ptr->ndims) {
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. .not. config_do_restart) .or. &</font>
<font color="blue">", struct_deref, var_ptr->super_array);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. config_do_restart)) then</font>
<font color="red">", struct_deref, var_ptr->super_array);
}
else {
- if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
- split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, "read%sCount%s", cp1, cp2);
- free(cp1);
- free(cp2);
- }
- else
- fortprintf(fd, "read%sCount", dimlist_ptr->dim->name_in_code+1);
+ fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. .not. config_do_restart) .or. &</font>
<font color="blue">", struct_deref, var_ptr->name_in_code);
+ fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. config_do_restart)) then</font>
<font color="red">", struct_deref, var_ptr->name_in_code);
}
-
- dimlist_ptr = dimlist_ptr->next;
- i++;
while (dimlist_ptr) {
- if (i < var_ptr->ndims) {
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
- }
- else {
- if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
- split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, ", read%sCount%s", cp1, cp2);
- free(cp1);
- free(cp2);
+ if (i < var_ptr->ndims) {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="blue">", vtype, var_ptr->ndims, i);
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " %s%id %% ioinfo %% count(%i) = block %% mesh %% %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " %s%id %% ioinfo %% count(%i) = block %% mesh %% %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %s</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
}
- else
- fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_code+1);
- }
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = read%sStart</font>
<font color="blue">", vtype, var_ptr->ndims, i, cp1);
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = read%sCount%s</font>
<font color="blue">", vtype, var_ptr->ndims, i, cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else {
+ if (dimlist_ptr->dim->namelist_defined) {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = read%sStart</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file+1);
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = read%sCount</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file+1);
+ }
+ else {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = read%sStart</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code+1);
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = read%sCount</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code+1);
+ }
+ }
+ }
dimlist_ptr = dimlist_ptr->next;
i++;
}
- fortprintf(fd, "))</font>
<font color="black"></font>
<font color="gray">");
-
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- fortprintf(fd, " allocate(super_%s%id(", vtype, var_ptr->ndims);
+
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " allocate(%s%id %% array(", vtype, var_ptr->ndims);
i = 1;
dimlist_ptr = var_ptr->dimlist;
@@ -963,166 +878,193 @@
else
fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
}
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, "read%sCount%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (dimlist_ptr->dim->namelist_defined) fortprintf(fd, "read%sCount", dimlist_ptr->dim->name_in_file+1);
+ else fortprintf(fd, "read%sCount", dimlist_ptr->dim->name_in_code+1);
+ }
+
dimlist_ptr = dimlist_ptr->next;
i++;
while (dimlist_ptr) {
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ if (i < var_ptr->ndims) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ }
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, ", read%sCount%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_code+1);
+ else fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_file+1);
+ }
dimlist_ptr = dimlist_ptr->next;
i++;
}
fortprintf(fd, "))</font>
<font color="black"></font>
<font color="red">");
- }
- }
-
- fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_file);
- if (var_ptr->timedim)
- fortprintf(fd, " call io_input_field_time(input_obj, %s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
- else
- fortprintf(fd, " call io_input_field(input_obj, %s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
-
- if (vert_dim > 0) {
- fortprintf(fd, "#ifdef EXPAND_LEVELS</font>
<font color="red">");
- fortprintf(fd, " if (.not. config_do_restart) then</font>
<font color="red">");
- fortprintf(fd, " do k=2,EXPAND_LEVELS</font>
<font color="red">");
- fortprintf(fd, " %s%id %% array(", vtype, var_ptr->ndims);
- for (i=1; i<=var_ptr->ndims; i++) {
- if (i > 1) fortprintf(fd, ",");
- fortprintf(fd, "%s", i == vert_dim ? "k" : ":");
- }
- fortprintf(fd, ") = %s%id %% array(", vtype, var_ptr->ndims);
- for (i=1; i<=var_ptr->ndims; i++) {
- if (i > 1) fortprintf(fd, ",");
- fortprintf(fd, "%s", i == vert_dim ? "1" : ":");
- }
- fortprintf(fd, ")</font>
<font color="red">");
- fortprintf(fd, " end do</font>
<font color="red">");
- fortprintf(fd, " end if</font>
<font color="red">");
- fortprintf(fd, "#endif</font>
<font color="red">");
- }
-
- if (var_ptr->ndims > 0) {
- fortprintf(fd, " call dmpar_alltoall_field(dminfo, &</font>
<font color="red">");
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- if (var_ptr->timedim)
- fortprintf(fd, " %s%id %% array, super_%s%id, &</font>
<font color="red">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
- else
- fortprintf(fd, " %s%id %% array, super_%s%id, &</font>
<font color="red">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
- }
- else {
- if (var_ptr->timedim)
- fortprintf(fd, " %s%id %% array, block %% time_levs(1) %% state %% %s %% array, &</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_code);
- else
- fortprintf(fd, " %s%id %% array, block %% mesh %% %s %% array, &</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_code);
- }
- i = 1;
- dimlist_ptr = var_ptr->dimlist;
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ fortprintf(fd, " allocate(super_%s%id(", vtype, var_ptr->ndims);
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
- if (i < var_ptr->ndims)
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, " block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, " %s", dimlist_ptr->dim->name_in_code);
- else {
- lastdim = dimlist_ptr;
- if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
- split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, " read%sCount%s", cp1, cp2);
- free(cp1);
- free(cp2);
+ if (i < var_ptr->ndims) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "%s", dimlist_ptr->dim->name_in_file);
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ while (dimlist_ptr) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_file);
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+ fortprintf(fd, "))</font>
<font color="black"></font>
<font color="red">");
}
- else
- fortprintf(fd, " read%sCount", dimlist_ptr->dim->name_in_code+1);
}
-
- dimlist_ptr = dimlist_ptr->next;
- i++;
- while (dimlist_ptr) {
+
+ fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="blue">", vtype, var_ptr->ndims, var_ptr->name_in_file);
+ if (var_ptr->timedim)
+ fortprintf(fd, " call io_input_field_time(input_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ else
+ fortprintf(fd, " call io_input_field(input_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " call dmpar_alltoall_field(dminfo, &</font>
<font color="blue">");
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ fortprintf(fd, " %s%id %% array, super_%s%id, &</font>
<font color="blue">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
+ else
+ fortprintf(fd, " %s%id %% array, %s %% %s %% array, &</font>
<font color="red">", vtype, var_ptr->ndims, struct_deref, var_ptr->name_in_code);
+
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+
if (i < var_ptr->ndims)
if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
else
- fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s", dimlist_ptr->dim->name_in_code);
else {
lastdim = dimlist_ptr;
if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, ", read%sCount%s", cp1, cp2);
+ fortprintf(fd, " read%sCount%s", cp1, cp2);
free(cp1);
free(cp2);
}
else
- fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_code+1);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " read%sCount", dimlist_ptr->dim->name_in_code+1);
+ else fortprintf(fd, " read%sCount", dimlist_ptr->dim->name_in_file+1);
}
+
dimlist_ptr = dimlist_ptr->next;
i++;
- }
- fortprintf(fd, ", block %% mesh %% %s, &</font>
<font color="red">", lastdim->dim->name_in_code);
-
- if (is_derived_dim(lastdim->dim->name_in_code)) {
- fortprintf(fd, " send%sList, recv%sList)</font>
<font color="red">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
- }
- else
- fortprintf(fd, " send%sList, recv%sList)</font>
<font color="red">", lastdim->dim->name_in_code+1, lastdim->dim->name_in_code+1);
-
-
- /* Copy from super_ array to field */
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- i = 1;
- dimlist_ptr = var_ptr->dimlist;
- while (i <= var_ptr->ndims) {
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " do i%i=1,block %% mesh %% %s</font>
<font color="red">", i, dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, " do i%i=1,block %% mesh %% %s</font>
<font color="red">", i, dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, " do i%i=1,%s</font>
<font color="red">", i, dimlist_ptr->dim->name_in_code);
-
- i++;
+ while (dimlist_ptr) {
+ if (i < var_ptr->ndims)
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", block %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ else {
+ lastdim = dimlist_ptr;
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, ", read%sCount%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_code+1);
+ else fortprintf(fd, ", read%sCount", dimlist_ptr->dim->name_in_file+1);
+ }
dimlist_ptr = dimlist_ptr->next;
+ i++;
}
-
- if (var_ptr->timedim)
- fortprintf(fd, " block %% time_levs(1) %% state %% %s %% array(index_%s,", var_ptr->super_array, var_ptr->name_in_code);
+ if (!lastdim->dim->namelist_defined) fortprintf(fd, ", block %% mesh %% %s, &</font>
<font color="blue">", lastdim->dim->name_in_code);
+ else fortprintf(fd, ", block %% mesh %% %s, &</font>
<font color="blue">", lastdim->dim->name_in_file);
+
+ if (is_derived_dim(lastdim->dim->name_in_code))
+ fortprintf(fd, " send%sList, recv%sList)</font>
<font color="red">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
else
- fortprintf(fd, " block %% mesh %% %s %% array(index_%s,", var_ptr->super_array, var_ptr->name_in_code);
- for(i=1; i<=var_ptr->ndims; i++) {
- fortprintf(fd, "i%i",i);
- if (i < var_ptr->ndims) fortprintf(fd, ",");
- }
- fortprintf(fd, ") = super_%s%id(", vtype, var_ptr->ndims);
- for(i=1; i<=var_ptr->ndims; i++) {
- fortprintf(fd, "i%i",i);
- if (i < var_ptr->ndims) fortprintf(fd, ",");
- }
- fortprintf(fd, ")</font>
<font color="blue">");
+ if (lastdim->dim->namelist_defined)
+ fortprintf(fd, " send%sList, recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
+ else
+ fortprintf(fd, " send%sList, recv%sList)</font>
<font color="red">", lastdim->dim->name_in_code+1, lastdim->dim->name_in_code+1);
- i = 1;
- while (i <= var_ptr->ndims) {
- fortprintf(fd, " end do</font>
<font color="red">");
- i++;
+
+ /* Copy from super_ array to field */
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+ while (i <= var_ptr->ndims) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " do i%i=1,block %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " do i%i=1,block %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " do i%i=1,%s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+
+ i++;
+ dimlist_ptr = dimlist_ptr->next;
+ }
+
+ fortprintf(fd, " %s %% %s %% array(%s %% index_%s,", struct_deref, var_ptr->super_array, struct_deref, var_ptr->name_in_code);
+
+ for(i=1; i<=var_ptr->ndims; i++) {
+ fortprintf(fd, "i%i",i);
+ if (i < var_ptr->ndims) fortprintf(fd, ",");
+ }
+ fortprintf(fd, ") = super_%s%id(", vtype, var_ptr->ndims);
+ for(i=1; i<=var_ptr->ndims; i++) {
+ fortprintf(fd, "i%i",i);
+ if (i < var_ptr->ndims) fortprintf(fd, ",");
+ }
+ fortprintf(fd, ")</font>
<font color="blue">");
+
+ i = 1;
+ while (i <= var_ptr->ndims) {
+ fortprintf(fd, " end do</font>
<font color="blue">");
+ i++;
+ }
}
+
+ fortprintf(fd, " deallocate(%s%id %% array)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ fortprintf(fd, " deallocate(super_%s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
}
-
- fortprintf(fd, " deallocate(%s%id %% array)</font>
<font color="red">", vtype, var_ptr->ndims);
- if (strncmp(var_ptr->super_array, "-", 1024) != 0)
- fortprintf(fd, " deallocate(super_%s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ else {
+ fortprintf(fd, " %s %% %s %% scalar = %s%id %% scalar</font>
<font color="blue">", struct_deref, var_ptr->name_in_code, vtype, var_ptr->ndims);
+ }
+
+ fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="red">");
+
+ var_list_ptr = var_list_ptr->next;
}
- else {
- if (var_ptr->timedim)
- fortprintf(fd, " block %% time_levs(1) %% state %% %s %% scalar = %s%id %% scalar</font>
<font color="red">", var_ptr->name_in_code, vtype, var_ptr->ndims);
- else
- fortprintf(fd, " block %% mesh %% %s %% scalar = %s%id %% scalar</font>
<font color="red">", var_ptr->name_in_code, vtype, var_ptr->ndims);
- }
-
- fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="gray">");
-
- var_ptr = var_ptr->next;
+ group_ptr = group_ptr->next;
}
fclose(fd);
@@ -1253,16 +1195,19 @@
}
-void gen_writes(struct variable * vars, struct dimension * dims, struct namelist * namelists)
+void gen_writes(struct group_list * groups, struct variable * vars, struct dimension * dims, struct namelist * namelists)
{
struct variable * var_ptr;
+ struct variable_list * var_list_ptr;
struct dimension * dim_ptr;
struct dimension_list * dimlist_ptr, * lastdim;
+ struct group_list * group_ptr;
struct dtable * dictionary;
struct namelist * nl;
FILE * fd;
char vtype[5];
char fname[32];
+ char struct_deref[1024];
char * cp1, * cp2;
int i, j;
int ivtype;
@@ -1409,226 +1354,224 @@
*/
fd = fopen("io_output_fields.inc", "w");
- var_ptr = vars;
- while (var_ptr) {
- i = 1;
- dimlist_ptr = var_ptr->dimlist;
- if (var_ptr->vtype == INTEGER) sprintf(vtype, "int");
- else if (var_ptr->vtype == REAL) sprintf(vtype, "real");
+ group_ptr = groups;
+ while (group_ptr) {
+ var_list_ptr = group_ptr->vlist;
+ while (var_list_ptr) {
+ var_ptr = var_list_ptr->var;
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- if (var_ptr->timedim) {
- fortprintf(fd, " if ((domain %% blocklist %% time_levs(1) %% state %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="red">", var_ptr->super_array);
- fortprintf(fd, " (domain %% blocklist %% time_levs(1) %% state %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART)) then</font>
<font color="red">", var_ptr->super_array);
- }
- else {
- fortprintf(fd, " if ((domain %% blocklist %% mesh %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="red">", var_ptr->super_array);
- fortprintf(fd, " (domain %% blocklist %% mesh %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART)) then</font>
<font color="red">", var_ptr->super_array);
- }
- }
- else {
- if (var_ptr->timedim) {
- fortprintf(fd, " if ((domain %% blocklist %% time_levs(1) %% state %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " (domain %% blocklist %% time_levs(1) %% state %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART)) then</font>
<font color="red">", var_ptr->name_in_code);
- }
- else {
- fortprintf(fd, " if ((domain %% blocklist %% mesh %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &</font>
<font color="red">", var_ptr->name_in_code);
- fortprintf(fd, " (domain %% blocklist %% mesh %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART)) then</font>
<font color="red">", var_ptr->name_in_code);
- }
- }
-
- if (var_ptr->ndims > 0) {
- while (dimlist_ptr) {
- if (i < var_ptr->ndims) {
- fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="red">", vtype, var_ptr->ndims, i);
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " %s%id %% ioinfo %% count(%i) = domain %% blocklist %% mesh %% %s</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, " %s%id %% ioinfo %% count(%i) = domain %% blocklist %% mesh %% %s</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %s</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
- }
- else {
- fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="red">", vtype, var_ptr->ndims, i);
- if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
- split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, " %s%id %% ioinfo %% count(%i) = n%sGlobal%s</font>
<font color="red">", vtype, var_ptr->ndims, i, cp1, cp2);
- free(cp1);
- free(cp2);
- }
- else
- fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %sGlobal</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
- }
- dimlist_ptr = dimlist_ptr->next;
- i++;
- }
-
- fortprintf(fd, " allocate(%s%id %% array(", vtype, var_ptr->ndims);
+ 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);
+
i = 1;
dimlist_ptr = var_ptr->dimlist;
+ if (var_ptr->vtype == INTEGER) sprintf(vtype, "int");
+ else if (var_ptr->vtype == REAL) sprintf(vtype, "real");
- if (i < var_ptr->ndims)
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ 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)) then</font>
<font color="red">", struct_deref, var_ptr->super_array);
+ }
else {
- if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
- split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, "n%sGlobal%s", cp1, cp2);
- free(cp1);
- free(cp2);
- }
- else
- fortprintf(fd, "%sGlobal", dimlist_ptr->dim->name_in_code);
- lastdim = dimlist_ptr;
+ 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)) then</font>
<font color="red">", struct_deref, var_ptr->name_in_code);
}
- dimlist_ptr = dimlist_ptr->next;
- i++;
- while (dimlist_ptr) {
+
+ if (var_ptr->ndims > 0) {
+ while (dimlist_ptr) {
+ if (i < var_ptr->ndims) {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="blue">", vtype, var_ptr->ndims, i);
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " %s%id %% ioinfo %% count(%i) = domain %% blocklist %% mesh %% %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " %s%id %% ioinfo %% count(%i) = domain %% blocklist %% mesh %% %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %s</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ }
+ else {
+ fortprintf(fd, " %s%id %% ioinfo %% start(%i) = 1</font>
<font color="blue">", vtype, var_ptr->ndims, i);
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, " %s%id %% ioinfo %% count(%i) = n%sGlobal%s</font>
<font color="blue">", vtype, var_ptr->ndims, i, cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %sGlobal</font>
<font color="blue">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " %s%id %% ioinfo %% count(%i) = %sGlobal</font>
<font color="red">", vtype, var_ptr->ndims, i, dimlist_ptr->dim->name_in_file);
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+
+ fortprintf(fd, " allocate(%s%id %% array(", vtype, var_ptr->ndims);
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+
if (i < var_ptr->ndims)
if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
else
- fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
else {
if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, ", n%sGlobal%s", cp1, cp2);
+ fortprintf(fd, "n%sGlobal%s", cp1, cp2);
free(cp1);
free(cp2);
}
else
- fortprintf(fd, ", %sGlobal", dimlist_ptr->dim->name_in_code);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%sGlobal", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "%sGlobal", dimlist_ptr->dim->name_in_file);
lastdim = dimlist_ptr;
}
dimlist_ptr = dimlist_ptr->next;
i++;
- }
- fortprintf(fd, "))</font>
<font color="black"></font>
<font color="red">");
-
- if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
- if (var_ptr->ndims > 0) {
- fortprintf(fd, " allocate(super_%s%id(", vtype, var_ptr->ndims);
+ while (dimlist_ptr) {
+ if (i < var_ptr->ndims)
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+ else {
+ if (is_derived_dim(dimlist_ptr->dim->name_in_code)) {
+ split_derived_dim_string(dimlist_ptr->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, ", n%sGlobal%s", cp1, cp2);
+ free(cp1);
+ free(cp2);
+ }
+ else
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %sGlobal", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", %sGlobal", dimlist_ptr->dim->name_in_file);
+ lastdim = dimlist_ptr;
+ }
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+ fortprintf(fd, "))</font>
<font color="black"></font>
<font color="blue">");
+
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0) {
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " allocate(super_%s%id(", vtype, var_ptr->ndims);
+ i = 1;
+ dimlist_ptr = var_ptr->dimlist;
+ while (dimlist_ptr) {
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+
+ if (i < var_ptr->ndims) fortprintf(fd, ", ");
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ }
+ fortprintf(fd, "))</font>
<font color="black"></font>
<font color="red">");
+ }
+
+ /* Copy from field to super_ array */
i = 1;
dimlist_ptr = var_ptr->dimlist;
- while (dimlist_ptr) {
+ while (i <= var_ptr->ndims) {
if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, "domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " do i%i=1,domain %% blocklist %% mesh %% %s</font>
<font color="blue">", i, dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " do i%i=1,domain %% blocklist %% mesh %% %s</font>
<font color="red">", i, dimlist_ptr->dim->name_in_file);
else
- fortprintf(fd, "%s", dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " do i%i=1,%s</font>
<font color="red">", i, dimlist_ptr->dim->name_in_code);
- if (i < var_ptr->ndims) fortprintf(fd, ", ");
-
+ i++;
dimlist_ptr = dimlist_ptr->next;
+ }
+
+ fortprintf(fd, " super_%s%id(", vtype, var_ptr->ndims);
+ for(i=1; i<=var_ptr->ndims; i++) {
+ fortprintf(fd, "i%i",i);
+ if (i < var_ptr->ndims) fortprintf(fd, ",");
+ }
+ fortprintf(fd, ") = %s %% %s %% array(", struct_deref, var_ptr->super_array);
+ fortprintf(fd, "%s %% index_%s", struct_deref, var_ptr->name_in_code);
+ for(i=1; i<=var_ptr->ndims; i++) {
+ fortprintf(fd, ",i%i",i);
+ }
+ fortprintf(fd, ")</font>
<font color="blue">");
+
+ i = 1;
+ while (i <= var_ptr->ndims) {
+ fortprintf(fd, " end do</font>
<font color="red">");
i++;
}
- fortprintf(fd, "))</font>
<font color="black"></font>
<font color="red">");
}
-
- /* Copy from field to super_ array */
+
+ fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="blue">", vtype, var_ptr->ndims, var_ptr->name_in_file);
+ fortprintf(fd, " call dmpar_alltoall_field(domain %% dminfo, &</font>
<font color="blue">");
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ fortprintf(fd, " super_%s%id, %s%id %% array, &</font>
<font color="blue">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
+ else
+ fortprintf(fd, " %s %% %s %% array, %s%id %% array, &</font>
<font color="red">", struct_deref, var_ptr->name_in_code, vtype, var_ptr->ndims);
+
i = 1;
dimlist_ptr = var_ptr->dimlist;
- while (i <= var_ptr->ndims) {
+
+ if (dimlist_ptr->dim->constant_value < 0)
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, " domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ else
+ fortprintf(fd, " %s", dimlist_ptr->dim->name_in_code);
+
+ dimlist_ptr = dimlist_ptr->next;
+ i++;
+ while (dimlist_ptr) {
if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " do i%i=1,domain %% blocklist %% mesh %% %s</font>
<font color="red">", i, dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, " do i%i=1,domain %% blocklist %% mesh %% %s</font>
<font color="red">", i, dimlist_ptr->dim->name_in_file);
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
+ else fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
else
- fortprintf(fd, " do i%i=1,%s</font>
<font color="red">", i, dimlist_ptr->dim->name_in_code);
-
- i++;
+ fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
+
dimlist_ptr = dimlist_ptr->next;
- }
-
- fortprintf(fd, " super_%s%id(", vtype, var_ptr->ndims);
- for(i=1; i<=var_ptr->ndims; i++) {
- fortprintf(fd, "i%i",i);
- if (i < var_ptr->ndims) fortprintf(fd, ",");
- }
- if (var_ptr->timedim)
- fortprintf(fd, ") = domain %% blocklist %% time_levs(1) %% state %% %s %% array(", var_ptr->super_array);
- else
- fortprintf(fd, ") = domain %% blocklist %% mesh %% %s %% array(", var_ptr->super_array);
- fortprintf(fd, "index_%s", var_ptr->name_in_code);
- for(i=1; i<=var_ptr->ndims; i++) {
- fortprintf(fd, ",i%i",i);
- }
- fortprintf(fd, ")</font>
<font color="red">");
-
- i = 1;
- while (i <= var_ptr->ndims) {
- fortprintf(fd, " end do</font>
<font color="blue">");
i++;
+ }
+
+ if (is_derived_dim(lastdim->dim->name_in_code)) {
+ split_derived_dim_string(lastdim->dim->name_in_code, &cp1, &cp2);
+ fortprintf(fd, ", n%sGlobal%s, &</font>
<font color="blue">", cp1, cp2);
+ fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
+ free(cp1);
+ free(cp2);
}
+ else {
+ if (!lastdim->dim->namelist_defined) {
+ fortprintf(fd, ", %sGlobal, &</font>
<font color="blue">", lastdim->dim->name_in_code);
+ fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="blue">", lastdim->dim->name_in_code+1, lastdim->dim->name_in_code+1);
+ }
+ else {
+ fortprintf(fd, ", %sGlobal, &</font>
<font color="blue">", lastdim->dim->name_in_file);
+ fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="red">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
+ }
+ }
}
-
- fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_file);
- fortprintf(fd, " call dmpar_alltoall_field(domain %% dminfo, &</font>
<font color="red">");
- if (strncmp(var_ptr->super_array, "-", 1024) != 0)
- fortprintf(fd, " super_%s%id, %s%id %% array, &</font>
<font color="red">", vtype, var_ptr->ndims, vtype, var_ptr->ndims);
else {
- if (var_ptr->timedim)
- fortprintf(fd, " domain %% blocklist %% time_levs(1) %% state %% %s %% array, %s%id %% array, &</font>
<font color="red">", var_ptr->name_in_code, vtype, var_ptr->ndims);
- else
- fortprintf(fd, " domain %% blocklist %% mesh %% %s %% array, %s%id %% array, &</font>
<font color="blue">", var_ptr->name_in_code, vtype, var_ptr->ndims);
+ fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="blue">", vtype, var_ptr->ndims, var_ptr->name_in_file);
+ fortprintf(fd, " %s%id %% scalar = %s %% %s %% scalar</font>
<font color="red">", vtype, var_ptr->ndims, struct_deref, var_ptr->name_in_code);
}
- i = 1;
- dimlist_ptr = var_ptr->dimlist;
-
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, " domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, " domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
+ if (var_ptr->timedim)
+ fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call io_output_field_time(output_obj, %s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
else
- fortprintf(fd, " %s", dimlist_ptr->dim->name_in_code);
-
- dimlist_ptr = dimlist_ptr->next;
- i++;
- while (dimlist_ptr) {
- if (dimlist_ptr->dim->constant_value < 0)
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_code);
- else fortprintf(fd, ", domain %% blocklist %% mesh %% %s", dimlist_ptr->dim->name_in_file);
- else
- fortprintf(fd, ", %s", dimlist_ptr->dim->name_in_code);
-
- dimlist_ptr = dimlist_ptr->next;
- i++;
- }
-
- if (is_derived_dim(lastdim->dim->name_in_code)) {
- split_derived_dim_string(lastdim->dim->name_in_code, &cp1, &cp2);
- fortprintf(fd, ", n%sGlobal%s, &</font>
<font color="red">", cp1, cp2);
- fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="red">", lastdim->dim->name_in_file+1, lastdim->dim->name_in_file+1);
- free(cp1);
- free(cp2);
+ fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call io_output_field(output_obj, %s%id)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ if (var_ptr->ndims > 0) {
+ fortprintf(fd, " deallocate(%s%id %% array)</font>
<font color="blue">", vtype, var_ptr->ndims);
+ if (strncmp(var_ptr->super_array, "-", 1024) != 0)
+ fortprintf(fd, " deallocate(super_%s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
}
- else {
- fortprintf(fd, ", %sGlobal, &</font>
<font color="red">", lastdim->dim->name_in_code);
- fortprintf(fd, " output_obj %% send%sList, output_obj %% recv%sList)</font>
<font color="red">", lastdim->dim->name_in_code+1, lastdim->dim->name_in_code+1);
- }
+ fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="red">");
+
+ var_list_ptr = var_list_ptr->next;
}
- else {
- fortprintf(fd, " %s%id %% ioinfo %% fieldName = \'%s\'</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_file);
- if (var_ptr->timedim)
- fortprintf(fd, " %s%id %% scalar = domain %% blocklist %% time_levs(1) %% state %% %s %% scalar</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_code);
- else
- fortprintf(fd, " %s%id %% scalar = domain %% blocklist %% mesh %% %s %% scalar</font>
<font color="red">", vtype, var_ptr->ndims, var_ptr->name_in_code);
- }
-
- if (var_ptr->timedim)
- fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call io_output_field_time(output_obj, %s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
- else
- fortprintf(fd, " if (domain %% dminfo %% my_proc_id == IO_NODE) call io_output_field(output_obj, %s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
- if (var_ptr->ndims > 0) {
- fortprintf(fd, " deallocate(%s%id %% array)</font>
<font color="red">", vtype, var_ptr->ndims);
- if (strncmp(var_ptr->super_array, "-", 1024) != 0)
- fortprintf(fd, " deallocate(super_%s%id)</font>
<font color="red">", vtype, var_ptr->ndims);
- }
- fortprintf(fd, " end if</font>
<font color="black"></font>
<font color="gray">");
-
- var_ptr = var_ptr->next;
+ group_ptr = group_ptr->next;
}
fclose(fd);
Modified: branches/swmodel_del4/src/registry/gen_inc.h
===================================================================
--- branches/swmodel_del4/src/registry/gen_inc.h 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/registry/gen_inc.h 2010-10-22 19:14:07 UTC (rev 578)
@@ -1,4 +1,4 @@
void gen_namelists(struct namelist *);
-void gen_field_defs(struct variable *, struct dimension *);
-void gen_reads(struct variable *, struct dimension *);
-void gen_writes(struct variable *, struct dimension *, struct namelist *);
+void gen_field_defs(struct group_list * groups, struct variable *, struct dimension *);
+void gen_reads(struct group_list * groups, struct variable *, struct dimension *);
+void gen_writes(struct group_list * groups, struct variable *, struct dimension *, struct namelist *);
Modified: branches/swmodel_del4/src/registry/parse.c
===================================================================
--- branches/swmodel_del4/src/registry/parse.c 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/registry/parse.c 2010-10-22 19:14:07 UTC (rev 578)
@@ -4,10 +4,11 @@
#include "registry_types.h"
#include "gen_inc.h"
-int parse_reg(FILE *, struct namelist **, struct dimension **, struct variable **);
+int parse_reg(FILE *, struct namelist **, struct dimension **, struct variable **, struct group_list **);
int getword(FILE *, char *);
int is_integer_constant(char *);
void sort_vars(struct variable *);
+void sort_group_vars(struct group_list *);
int main(int argc, char ** argv)
{
@@ -15,6 +16,7 @@
struct namelist * nls;
struct dimension * dims;
struct variable * vars;
+ struct group_list * groups;
if (argc != 2) {
fprintf(stderr,"</font>
<font color="black">Usage: %s filename</font>
<font color="black"></font>
<font color="gray">", argv[0]);
@@ -25,7 +27,7 @@
nls = NULL;
dims = NULL;
vars = NULL;
- if (parse_reg(regfile, &nls, &dims, &vars)) {
+ if (parse_reg(regfile, &nls, &dims, &vars, &groups)) {
return 1;
}
}
@@ -35,17 +37,18 @@
}
sort_vars(vars);
+ sort_group_vars(groups);
gen_namelists(nls);
- gen_field_defs(vars, dims);
- gen_reads(vars, dims);
- gen_writes(vars, dims, nls);
+ gen_field_defs(groups, vars, dims);
+ gen_reads(groups, vars, dims);
+ gen_writes(groups, vars, dims, nls);
return 0;
}
-int parse_reg(FILE * regfile, struct namelist ** nls, struct dimension ** dims, struct variable ** vars)
+int parse_reg(FILE * regfile, struct namelist ** nls, struct dimension ** dims, struct variable ** vars, struct group_list ** groups)
{
char word[1024];
struct namelist * nls_ptr;
@@ -54,13 +57,17 @@
struct variable * var_ptr;
struct dimension_list * dimlist_ptr;
struct dimension * dimlist_cursor;
+ struct group_list * grouplist_ptr;
+ struct variable_list * vlist_cursor;
NEW_NAMELIST(nls_ptr)
NEW_DIMENSION(dim_ptr)
NEW_VARIABLE(var_ptr)
+ NEW_GROUP_LIST(grouplist_ptr);
*nls = nls_ptr;
*dims = dim_ptr;
*vars = var_ptr;
+ *groups = grouplist_ptr;
while(getword(regfile, word) != EOF) {
if (strncmp(word, "namelist", 1024) == 0) {
@@ -130,7 +137,16 @@
var_ptr->timedim = 0;
var_ptr->iostreams = 0;
+ /*
+ * persistence
+ */
getword(regfile, word);
+ if (strncmp(word, "persistent", 1024) == 0)
+ var_ptr->persistence = PERSISTENT;
+ else if (strncmp(word, "scratch", 1024) == 0)
+ var_ptr->persistence = SCRATCH;
+
+ getword(regfile, word);
if (strncmp(word, "real", 1024) == 0)
var_ptr->vtype = REAL;
else if (strncmp(word, "integer", 1024) == 0)
@@ -168,14 +184,50 @@
getword(regfile, word);
}
- /* Read I/O info */
+ /*
+ * time_dim
+ */
getword(regfile, word);
+ var_ptr->ntime_levs = atoi(word);
+
+ /*
+ * I/O info
+ */
+ getword(regfile, word);
if (strchr(word, (int)'i')) var_ptr->iostreams |= INPUT0;
if (strchr(word, (int)'r')) var_ptr->iostreams |= RESTART0;
if (strchr(word, (int)'o')) var_ptr->iostreams |= OUTPUT0;
getword(regfile, var_ptr->name_in_code);
+ /*
+ * struct
+ */
+ getword(regfile, var_ptr->struct_group);
+ grouplist_ptr = *groups;
+ grouplist_ptr = grouplist_ptr->next;
+ while (grouplist_ptr && strncmp(var_ptr->struct_group, grouplist_ptr->name, 1024)) {
+ grouplist_ptr = grouplist_ptr->next;
+ }
+ if (!grouplist_ptr) {
+ grouplist_ptr = *groups;
+ while(grouplist_ptr->next) grouplist_ptr = grouplist_ptr->next;
+ NEW_GROUP_LIST(grouplist_ptr->next);
+ grouplist_ptr = grouplist_ptr->next;
+ memcpy(grouplist_ptr->name, var_ptr->struct_group, (size_t)1024);
+ NEW_VARIABLE_LIST(grouplist_ptr->vlist);
+ grouplist_ptr->vlist->var = var_ptr;
+ }
+ else {
+ vlist_cursor = grouplist_ptr->vlist;
+ while (vlist_cursor->next) vlist_cursor = vlist_cursor->next;
+ NEW_VARIABLE_LIST(vlist_cursor->next);
+ vlist_cursor->next->prev = vlist_cursor;
+ vlist_cursor = vlist_cursor->next;
+ vlist_cursor->var = var_ptr;
+ }
+
+
getword(regfile, var_ptr->super_array);
getword(regfile, var_ptr->array_class);
@@ -203,6 +255,10 @@
if ((*vars)->next) *vars = (*vars)->next;
if (var_ptr) free(var_ptr);
+ grouplist_ptr = *groups;
+ if ((*groups)->next) *groups = (*groups)->next;
+ if (grouplist_ptr) free(grouplist_ptr);
+
return 0;
}
@@ -252,7 +308,7 @@
var_ptr = vars;
-/*
+/* Attempt at sorting first on super-array, then on class in the same loop
while (var_ptr) {
memcpy(super_array, var_ptr->super_array, 1024);
memcpy(array_class, var_ptr->array_class, 1024);
@@ -321,3 +377,68 @@
var_ptr = var_ptr->next;
}
}
+
+
+void sort_group_vars(struct group_list * groups)
+{
+ struct variable_list * var_list;
+ struct variable_list * var_ptr;
+ struct variable_list * var_ptr2;
+ struct variable_list * var_ptr2_prev;
+ struct group_list * group_ptr;
+ char super_array[1024];
+ char array_class[1024];
+
+ group_ptr = groups;
+
+ while (group_ptr) {
+
+ var_ptr = group_ptr->vlist;
+
+ while (var_ptr) {
+ memcpy(super_array, var_ptr->var->super_array, 1024);
+ var_ptr2_prev = var_ptr;
+ var_ptr2 = var_ptr->next;
+ if (var_ptr2 && strncmp(super_array, var_ptr2->var->super_array, 1024) != 0) {
+ while (var_ptr2) {
+ if (strncmp(super_array, var_ptr2->var->super_array, 1024) == 0) {
+ var_ptr2_prev->next = var_ptr2->next;
+ var_ptr2->next = var_ptr->next;
+ var_ptr->next = var_ptr2;
+ var_ptr2 = var_ptr2_prev->next;
+ }
+ else {
+ var_ptr2_prev = var_ptr2_prev->next;
+ var_ptr2 = var_ptr2->next;
+ }
+ }
+ }
+ var_ptr = var_ptr->next;
+ }
+
+ var_ptr = group_ptr->vlist;
+
+ while (var_ptr) {
+ memcpy(array_class, var_ptr->var->array_class, 1024);
+ var_ptr2_prev = var_ptr;
+ var_ptr2 = var_ptr->next;
+ if (var_ptr2 && strncmp(array_class, var_ptr2->var->array_class, 1024) != 0) {
+ while (var_ptr2) {
+ if (strncmp(array_class, var_ptr2->var->array_class, 1024) == 0) {
+ var_ptr2_prev->next = var_ptr2->next;
+ var_ptr2->next = var_ptr->next;
+ var_ptr->next = var_ptr2;
+ var_ptr2 = var_ptr2_prev->next;
+ }
+ else {
+ var_ptr2_prev = var_ptr2_prev->next;
+ var_ptr2 = var_ptr2->next;
+ }
+ }
+ }
+ var_ptr = var_ptr->next;
+ }
+
+ group_ptr = group_ptr->next;
+ }
+}
Modified: branches/swmodel_del4/src/registry/registry_types.h
===================================================================
--- branches/swmodel_del4/src/registry/registry_types.h 2010-10-22 18:35:44 UTC (rev 577)
+++ branches/swmodel_del4/src/registry/registry_types.h 2010-10-22 19:14:07 UTC (rev 578)
@@ -3,6 +3,9 @@
#define LOGICAL 2
#define CHARACTER 3
+#define PERSISTENT 0
+#define SCRATCH 1
+
#define INPUT0 0x00000001
#define RESTART0 0x00000002
#define OUTPUT0 0x00000004
@@ -11,6 +14,8 @@
#define NEW_DIMENSION(X) X = (struct dimension *)malloc(sizeof(struct dimension)); X->next = NULL;
#define NEW_DIMENSION_LIST(X) X = (struct dimension_list *)malloc(sizeof(struct dimension_list)); X->dim = NULL; X->prev = NULL; X->next = NULL;
#define NEW_VARIABLE(X) X = (struct variable *)malloc(sizeof(struct variable)); X->dimlist = NULL; X->next = NULL;
+#define NEW_VARIABLE_LIST(X) X = (struct variable_list *)malloc(sizeof(struct variable_list)); X->var = NULL; X->prev = NULL; X->next = NULL;
+#define NEW_GROUP_LIST(X) X = (struct group_list *)malloc(sizeof(struct group_list)); X->vlist = NULL; X->next = NULL;
union default_val {
int ival;
@@ -41,14 +46,29 @@
struct dimension_list * next;
};
+struct variable_list {
+ struct variable * var;
+ struct variable_list * prev;
+ struct variable_list * next;
+};
+
+struct group_list {
+ char name[1024];
+ struct variable_list * vlist;
+ struct group_list * next;
+};
+
struct variable {
char name_in_file[1024];
char name_in_code[1024];
+ char struct_group[1024];
char super_array[1024];
char array_class[1024];
+ int persistence;
int vtype;
int ndims;
int timedim;
+ int ntime_levs;
int iostreams;
struct dimension_list * dimlist;
struct variable * next;
</font>
</pre>