<p><b>dwj07@fsu.edu</b> 2013-03-08 10:10:33 -0700 (Fri, 08 Mar 2013)</p><p><br>
-- BRANCH COMMIT --<br>
<br>
Merging trunk to branch.<br>
Cleaning up ocean Makefile, and interface names.<br>
</p><hr noshade><pre><font color="gray">Index: branches/ocean_projects/shared_advection
===================================================================
--- branches/ocean_projects/shared_advection 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection 2013-03-08 17:10:33 UTC (rev 2572)
Property changes on: branches/ocean_projects/shared_advection
___________________________________________________________________
Modified: svn:mergeinfo
## -3,11 +3,22 ##
/branches/ocean_projects/ale_split_exp:1437-1483
/branches/ocean_projects/ale_vert_coord:1225-1383
/branches/ocean_projects/ale_vert_coord_new:1387-1428
+/branches/ocean_projects/cesm_coupling:2147-2344
+/branches/ocean_projects/diagnostics_revision:2439-2462
+/branches/ocean_projects/explicit_vmix_removal:2486-2490
/branches/ocean_projects/gmvar:1214-1514,1517-1738
/branches/ocean_projects/imp_vert_mix_error:1847-1887
/branches/ocean_projects/imp_vert_mix_mrp:754-986
+/branches/ocean_projects/leith_mrp:2182-2241
+/branches/ocean_projects/linear_eos:2435-2437
/branches/ocean_projects/monotonic_advection:1499-1640
/branches/ocean_projects/monthly_forcing:1810-1867
+/branches/ocean_projects/namelist_cleanup:2319-2414
+/branches/ocean_projects/option3_b4b_test:2201-2231
+/branches/ocean_projects/partial_bottom_cells:2172-2226
+/branches/ocean_projects/remove_sw_test_cases:2539-2540
+/branches/ocean_projects/restart_reproducibility:2239-2272
+/branches/ocean_projects/sea_level_pressure:2488-2528
/branches/ocean_projects/split_explicit_mrp:1134-1138
/branches/ocean_projects/split_explicit_timestepping:1044-1097
/branches/ocean_projects/vert_adv_mrp:704-745
## -20,3 +31,4 ##
/branches/omp_blocks/multiple_blocks:1803-2084
/branches/source_renaming:1082-1113
/branches/time_manager:924-962
+/trunk/mpas:2091-2563
\ No newline at end of property
Modified: branches/ocean_projects/shared_advection/Makefile
===================================================================
--- branches/ocean_projects/shared_advection/Makefile 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/Makefile 2013-03-08 17:10:33 UTC (rev 2572)
@@ -195,8 +195,15 @@
CPPINCLUDES = -I../inc -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include
FCINCLUDES = -I../inc -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include
-LIBS = -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -lpio -lpnetcdf -lnetcdf
+LIBS = -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -lpio -lpnetcdf
+NCLIB = -lnetcdf
+NCLIBF = -lnetcdff
+ifneq ($(wildcard $(NETCDF)/lib/libnetcdff.*), ) # CHECK FOR NETCDF4
+ LIBS += $(NCLIBF)
+endif # CHECK FOR NETCDF4
+LIBS += $(NCLIB)
+
RM = rm -f
CPP = cpp -C -P -traditional
RANLIB = ranlib
@@ -231,8 +238,9 @@
DEBUG_MESSAGE="Debug flags are not defined for this compile group. Defaulting to Optimized flags"
else # FFLAGS_DEBUG IF
FFLAGS=$(FFLAGS_DEBUG)
- CFLAGS=$(CFLAGS_DEBUG) -DMPAS_DEBUG
+ CFLAGS=$(CFLAGS_DEBUG)
LDFLAGS=$(LDFLAGS_DEBUG)
+ override CPPFLAGS += -DMPAS_DEBUG
DEBUG_MESSAGE="Debugging is on."
endif # FFLAGS_DEBUG IF
@@ -267,10 +275,16 @@
PAPI_MESSAGE="Papi libraries are off."
endif # USE_PAPI IF
-ifneq ($(wildcard $(NETCDF)/lib/libnetcdff.*), ) # CHECK FOR NETCDF4
- LIBS += -lnetcdff
-endif # CHECK FOR NETCDF4
+ifeq "$(TAU)" "true"
+ LINKER=tau_f90.sh
+ CPPINCLUDES += -DMPAS_TAU
+ TAU_MESSAGE="TAU Hooks are on."
+else
+ LINKER=$(FC)
+ TAU_MESSAGE="TAU Hooks are off."
+endif
+
####################################################
# Section for adding external libraries and includes
####################################################
@@ -291,6 +305,7 @@
CC="$(CC)" \
SFC="$(SFC)" \
SCC="$(SCC)" \
+ LINKER="$(LINKER)" \
CFLAGS="$(CFLAGS)" \
FFLAGS="$(FFLAGS)" \
LDFLAGS="$(LDFLAGS)" \
@@ -306,6 +321,7 @@
@echo $(DEBUG_MESSAGE)
@echo $(SERIAL_MESSAGE)
@echo $(PAPI_MESSAGE)
+ @echo $(TAU_MESSAGE)
clean:
cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)"
$(RM) $(CORE)_model.exe
@@ -337,9 +353,10 @@
@cd src; ls -d core_* | grep ".*" | sed "s/core_/ /g"
@echo ""
@echo "Available Options:"
- @echo " SERIAL=true - builds serial version. Default is parallel version."
- @echo " DEBUG=true - builds debug version. Default is optimized version."
- @echo " USE_PAPI=true - builds version using PAPI for timers and hardware counters. Default is off."
+ @echo " SERIAL=true - builds serial version. Default is parallel version."
+ @echo " DEBUG=true - builds debug version. Default is optimized version."
+ @echo " USE_PAPI=true - builds version using PAPI for timers. Default is off."
+ @echo " TAU=true - builds version using TAU hooks for profiling. Default is off."
@echo ""
@echo "Ensure that NETCDF (and PAPI if USE_PAPI=true) are environment variables"
@echo "that point to the absolute paths for the libraries."
Modified: branches/ocean_projects/shared_advection/namelist.input.init_nhyd_atmos
===================================================================
--- branches/ocean_projects/shared_advection/namelist.input.init_nhyd_atmos 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/namelist.input.init_nhyd_atmos 2013-03-08 17:10:33 UTC (rev 2572)
@@ -5,6 +5,12 @@
config_stop_time = '2010-10-23_00:00:00'
/
+&dcmip
+ config_dcmip_case = '2-0-0'
+ config_planet_scale = 1.0
+ config_rotation_rate_scale = 1.0
+/
+
&dimensions
config_nvertlevels = 41
config_nsoillevels = 4
@@ -33,8 +39,8 @@
/
&io
- config_input_name = 'x1.40962.geogrid.nc'
- config_output_name = 'x1.40962.init.2010-10-23.nc'
+ config_input_name = 'x1.40962.grid.nc'
+ config_output_name = 'x1.40962.init.nc'
config_pio_num_iotasks = 0
config_pio_stride = 1
/
@@ -47,7 +53,4 @@
/
&restart
- config_restart_interval = 3000
- config_do_restart = .false.
- config_restart_time = 1036800.0
/
Modified: branches/ocean_projects/shared_advection/namelist.input.nhyd_atmos
===================================================================
--- branches/ocean_projects/shared_advection/namelist.input.nhyd_atmos 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/namelist.input.nhyd_atmos 2013-03-08 17:10:33 UTC (rev 2572)
@@ -4,12 +4,12 @@
config_start_time = '2010-10-23_00:00:00'
config_run_duration = '5_00:00:00'
config_number_of_sub_steps = 6
- config_h_mom_eddy_visc2 = 0000.
- config_h_mom_eddy_visc4 = 0.
- config_v_mom_eddy_visc2 = 00.0
- config_h_theta_eddy_visc2 = 0000.
- config_h_theta_eddy_visc4 = 00.
- config_v_theta_eddy_visc2 = 00.0
+ config_h_mom_eddy_visc2 = 0.0
+ config_h_mom_eddy_visc4 = 0.0
+ config_v_mom_eddy_visc2 = 0.0
+ config_h_theta_eddy_visc2 = 0.0
+ config_h_theta_eddy_visc4 = 0.0
+ config_v_theta_eddy_visc2 = 0.0
config_horiz_mixing = '2d_smagorinsky'
config_len_disp = 120000.0
config_theta_adv_order = 3
@@ -35,12 +35,8 @@
config_xnutr = 0.0
/
-&dimensions
- config_nvertlevels = 41
-/
-
&io
- config_input_name = 'x1.40962.init.2010-10-23.nc'
+ config_input_name = 'x1.40962.init.nc'
config_output_name = 'x1.40962.output.nc'
config_restart_name = 'restart.nc'
config_output_interval = '1_00:00:00'
Modified: branches/ocean_projects/shared_advection/namelist.input.nhyd_atmos_jw
===================================================================
--- branches/ocean_projects/shared_advection/namelist.input.nhyd_atmos_jw 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/namelist.input.nhyd_atmos_jw 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,18 +1,17 @@
&nhyd_model
- config_test_case = 2
config_time_integration = 'SRK3'
config_dt = 450
- config_ntimesteps = 1920
- config_output_interval = 192
+ config_start_time = '0000-01-01_00:00:00'
+ config_run_duration = '10_00:00:00'
config_number_of_sub_steps = 6
- config_h_mom_eddy_visc2 = 0.0e+04
- config_h_mom_eddy_visc4 = 0.
- config_v_mom_eddy_visc2 = 00.0
- config_h_theta_eddy_visc2 = 0.0e+04
- config_h_theta_eddy_visc4 = 00.
- config_v_theta_eddy_visc2 = 00.0
+ config_h_mom_eddy_visc2 = 0.0
+ config_h_mom_eddy_visc4 = 0.0
+ config_v_mom_eddy_visc2 = 0.0
+ config_h_theta_eddy_visc2 = 0.0
+ config_h_theta_eddy_visc4 = 0.0
+ config_v_theta_eddy_visc2 = 0.0
config_horiz_mixing = '2d_smagorinsky'
- config_len_disp = 60000.
+ config_len_disp = 120000.
config_u_vadv_order = 3
config_w_vadv_order = 3
config_theta_vadv_order = 3
@@ -39,7 +38,7 @@
/
&io
- config_input_name = 'grid.nc'
+ config_input_name = 'x1.40962.init.nc'
config_output_name = 'output.nc'
config_restart_name = 'restart.nc'
config_pio_num_iotasks = 0
@@ -48,15 +47,14 @@
&decomposition
config_number_of_blocks = 0
- config_block_decomp_file_prefix = 'graph.info.part.'
+ config_block_decomp_file_prefix = 'x1.40962.graph.info.part.'
config_explicit_proc_decomp = .false.
config_proc_decomp_file_prefix = 'graph.info.part.'
/
&restart
- config_restart_interval = 3000
+ config_restart_interval = '10_00:00:00'
config_do_restart = .false.
- config_restart_time = 1036800.0
/
&physics
Modified: branches/ocean_projects/shared_advection/namelist.input.ocean
===================================================================
--- branches/ocean_projects/shared_advection/namelist.input.ocean 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/namelist.input.ocean 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,96 +1,164 @@
-&sw_model
- config_test_case = 0
- config_time_integration = 'split_explicit'
- config_rk_filter_btr_mode = .false.
- config_dt = 180.0
- config_start_time = '0000-01-01_00:00:00'
- config_run_duration = '1_00:00:00'
- config_stats_interval = 480
+&time_management
+ config_do_restart = .false.
+ config_start_time = '0000-01-01_00:00:00'
+ config_stop_time = 'none'
+ config_run_duration = '0_06:00:00'
+ config_calendar_type = '360day'
/
&io
- config_input_name = 'grid.nc'
- config_output_name = 'output..nc'
- config_restart_name = 'restart.nc'
- config_output_interval = '1_00:00:00'
- config_frames_per_outfile = 1000000
- config_pio_num_iotasks = 0
- config_pio_stride = 1
+ config_input_name = 'grid.nc'
+ config_output_name = 'output.nc'
+ config_restart_name = 'restart.nc'
+ config_restart_interval = '0_06:00:00'
+ config_output_interval = '0_06:00:00'
+ config_stats_interval = '0_01:00:00'
+ config_write_stats_on_startup = .true.
+ config_write_output_on_startup = .true.
+ config_frames_per_outfile = 1000
+ config_pio_num_iotasks = 0
+ config_pio_stride = 1
/
-&decomposition
- config_number_of_blocks = 0
- config_block_decomp_file_prefix = 'graph.info.part.'
- config_explicit_proc_decomp = .false.
- config_proc_decomp_file_prefix = 'graph.info.part.'
+&time_integration
+ config_dt = 3000.0
+ config_time_integrator = 'split_explicit'
/
-&restart
- config_do_restart = .false.
- config_restart_interval = '120_00:00:00'
-/
&grid
- config_vert_grid_type = 'isopycnal'
- config_pressure_type = 'pressure'
- config_rho0 = 1014.65
+ config_num_halos = 3
+ config_vert_coord_movement = 'uniform_stretching'
+ config_alter_ICs_for_pbcs = 'zlevel_pbcs_off'
+ config_min_pbc_fraction = 0.10
+ config_check_ssh_consistency = .true.
+ config_dzdk_positive = .false.
/
-&split_explicit_ts
- config_n_ts_iter = 2
- config_n_bcl_iter_beg = 1
- config_n_bcl_iter_mid = 2
- config_n_bcl_iter_end = 2
- config_n_btr_subcycles = 10
- config_n_btr_cor_iter = 2
- config_u_correction = .true.
- config_filter_btr_mode = .false.
- config_btr_subcycle_loop_factor = 2
- config_btr_gam1_uWt1 = 0.5
- config_btr_gam2_SSHWt1 = 1.0
- config_btr_gam3_uWt2 = 1.0
- config_btr_solve_SSH2 = .false.
+&decomposition
+ config_block_decomp_file_prefix = 'graph.info.part.'
+ config_number_of_blocks = 0
+ config_explicit_proc_decomp = .false.
+ config_proc_decomp_file_prefix = 'graph.info.part.'
/
&hmix
- config_h_mom_eddy_visc2 = 100.0
- config_h_mom_eddy_visc4 = 0.0
- config_h_kappa = 0.0
- config_h_kappa_q = 0.0
- config_visc_vorticity_term = .true.
- config_h_tracer_eddy_diff2 = 1.0e5
- config_h_tracer_eddy_diff4 = 0.0
+ config_hmix_ScaleWithMesh = .false.
+ config_visc_vorticity_term = .true.
+ config_apvm_scale_factor = 0.0
/
+&hmix_del2
+ config_use_mom_del2 = .false.
+ config_use_tracer_del2 = .false.
+ config_mom_del2 = 0.0
+ config_tracer_del2 = 0.0
+ config_vorticity_del2_scale = 1.0
+/
+&hmix_del4
+ config_use_mom_del4 = .true.
+ config_use_tracer_del4 = .false.
+ config_mom_del4 = 5.0e13
+ config_tracer_del4 = 0.0
+ config_vorticity_del4_scale = 1.0
+/
+&hmix_Leith
+ config_use_Leith_del2 = .false.
+ config_Leith_parameter = 1.0
+ config_Leith_dx = 15000.0
+ config_Leith_visc2_max = 2.5e3
+/
+&standard_GM
+ config_h_kappa = 0.0
+ config_h_kappa_q = 0.0
+/
+&Rayleigh_damping
+ config_Rayleigh_friction = .false.
+ config_Rayleigh_damping_coeff = 0.0
+/
&vmix
- config_vert_visc_type = 'const'
- config_vert_diff_type = 'const'
- config_implicit_vertical_mix = .true.
- config_convective_visc = 1.0
- config_convective_diff = 1.0
- config_bottom_drag_coeff = 1.0e-3
+ config_convective_visc = 1.0
+ config_convective_diff = 1.0
/
&vmix_const
- config_vert_visc = 1.0e-5
- config_vert_diff = 1.0e-5
+ config_use_const_visc = .false.
+ config_use_const_diff = .false.
+ config_vert_visc = 2.5e-4
+ config_vert_diff = 2.5e-5
/
&vmix_rich
- config_bkrd_vert_visc = 1.0e-5
- config_bkrd_vert_diff = 1.0e-5
- config_rich_mix = 0.005
+ config_use_rich_visc = .true.
+ config_use_rich_diff = .true.
+ config_bkrd_vert_visc = 1.0e-4
+ config_bkrd_vert_diff = 1.0e-5
+ config_rich_mix = 0.005
/
&vmix_tanh
- config_max_visc_tanh = 2.5e-1
- config_min_visc_tanh = 1.0e-4
- config_max_diff_tanh = 2.5e-2
- config_min_diff_tanh = 1.0e-5
- config_zMid_tanh = -100
- config_zWidth_tanh = 100
+ config_use_tanh_visc = .false.
+ config_use_tanh_diff = .false.
+ config_max_visc_tanh = 2.5e-1
+ config_min_visc_tanh = 1.0e-4
+ config_max_diff_tanh = 2.5e-2
+ config_min_diff_tanh = 1.0e-5
+ config_zMid_tanh = -100
+ config_zWidth_tanh = 100
/
-&eos
- config_eos_type = 'linear'
+&forcing
+ config_use_monthly_forcing = .false.
+ config_restoreTS = .false.
+ config_restoreT_timescale = 90.0
+ config_restoreS_timescale = 90.0
/
&advection
- config_vert_tracer_adv_order = 2
- config_horiz_tracer_adv_order = 2
- config_thickness_adv_order = 2
- config_monotonic = .false.
+ config_vert_tracer_adv = 'stencil'
+ config_vert_tracer_adv_order = 3
+ config_horiz_tracer_adv_order = 3
+ config_coef_3rd_order = 0.25
+ config_monotonic = .true.
/
-&restore
- config_restoreTS = .false.
- config_restoreT_timescale = 90.0
- config_restoreS_timescale = 90.0
+&bottom_drag
+ config_bottom_drag_coeff = 1.0e-3
/
+&pressure_gradient
+ config_pressure_gradient_type = 'pressure_and_zmid'
+ config_rho0 = 1014.65
+/
+&eos
+ config_eos_type = 'jm'
+/
+&eos_linear
+ config_eos_linear_alpha = 2.55e-1
+ config_eos_linear_beta = 7.64e-1
+ config_eos_linear_Tref = 19.0
+ config_eos_linear_Sref = 35.0
+ config_eos_linear_rhoref = 1025.022
+/
+&split_explicit_ts
+ config_n_ts_iter = 2
+ config_n_bcl_iter_beg = 1
+ config_n_bcl_iter_mid = 2
+ config_n_bcl_iter_end = 2
+ config_n_btr_subcycles = 20
+ config_n_btr_cor_iter = 2
+ config_u_correction = .true.
+ config_btr_subcycle_loop_factor = 2
+ config_btr_gam1_uWt1 = 0.5
+ config_btr_gam2_SSHWt1 = 1.0
+ config_btr_gam3_uWt2 = 1.0
+ config_btr_solve_SSH2 = .false.
+/
+&debug
+ config_check_zlevel_consistency = .false.
+ config_filter_btr_mode = .false.
+ config_prescribe_velocity = .false.
+ config_prescribe_thickness = .false.
+ config_include_KE_vertex = .false.
+ config_check_tracer_monotonicity = .false.
+ config_disable_h_all_tend = .false.
+ config_disable_h_hadv = .false.
+ config_disable_h_vadv = .false.
+ config_disable_u_all_tend = .false.
+ config_disable_u_coriolis = .false.
+ config_disable_u_pgrad = .false.
+ config_disable_u_hmix = .false.
+ config_disable_u_windstress = .false.
+ config_disable_u_vmix = .false.
+ config_disable_u_vadv = .false.
+ config_disable_tr_all_tend = .false.
+ config_disable_tr_adv = .false.
+ config_disable_tr_hmix = .false.
+ config_disable_tr_vmix = .false.
+/
Modified: branches/ocean_projects/shared_advection/src/Makefile
===================================================================
--- branches/ocean_projects/shared_advection/src/Makefile 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/Makefile 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,34 +1,45 @@
.SUFFIXES: .F .c .o
+ifeq "$(CESM)" "true"
+
+ifeq "$(CORE)" "ocean"
+include Makefile.in.CESM_OCN
+endif
+
+else
+
all: mpas
+
mpas: reg_includes externals frame ops dycore drver
- $(FC) $(LDFLAGS) -o $(CORE)_model.exe driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time
+ $(LINKER) $(LDFLAGS) -o $(CORE)_model.exe driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time
+externals: reg_includes
+ ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" )
+
+drver: reg_includes externals frame ops dycore
+ ( cd driver; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all )
+endif
+
reg_includes:
( cd registry; $(MAKE) CC="$(SCC)" )
( cd inc; $(CPP) ../core_$(CORE)/Registry | ../registry/parse > Registry.processed)
-externals: reg_includes
- ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" )
-
frame: reg_includes externals
- ( cd framework; $(MAKE) all )
+ ( cd framework; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all )
ln -sf framework/libframework.a libframework.a
ops: reg_includes externals frame
- ( cd operators; $(MAKE) all )
+ ( cd operators; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all )
ln -sf operators/libops.a libops.a
dycore: reg_includes externals frame ops
- ( cd core_$(CORE); $(MAKE) all )
+ ( cd core_$(CORE); $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all )
ln -sf core_$(CORE)/libdycore.a libdycore.a
-drver: reg_includes externals frame ops dycore
- ( cd driver; $(MAKE) all )
clean:
- $(RM) $(CORE)_model.exe libframework.a libops.a libdycore.a
+ $(RM) $(CORE)_model.exe libframework.a libops.a libdycore.a lib$(CORE).a *.o
( cd registry; $(MAKE) clean )
( cd external; $(MAKE) clean )
( cd framework; $(MAKE) clean )
Copied: branches/ocean_projects/shared_advection/src/Makefile.in.CESM_OCN (from rev 2563, trunk/mpas/src/Makefile.in.CESM_OCN)
===================================================================
--- branches/ocean_projects/shared_advection/src/Makefile.in.CESM_OCN (rev 0)
+++ branches/ocean_projects/shared_advection/src/Makefile.in.CESM_OCN 2013-03-08 17:10:33 UTC (rev 2572)
@@ -0,0 +1,32 @@
+include $(CASEROOT)/Macros
+RM = rm -f
+CPP = cpp -C -P -traditional
+FC=$(MPIFC)
+CC=$(MPICC)
+NETCDF=$(NETCDF_PATH)
+PNETCDF=$(PNETCDF_PATH)
+PIO=$(EXEROOT)/pio
+FILE_OFFSET = -DOFFSET64BIT
+CPPFLAGS += $(MODEL_FORMULATION) $(FILE_OFFSET) $(ZOLTAN_DEFINE) -DMPAS_CESM -D_MPI# -DUNDERSCORE
+CPPINCLUDES += -I$(EXEROOT)/ocn/source/inc -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include
+FCINCLUDES += -I$(EXEROOT)/ocn/source/inc -I$(EXEROOT)/csm_share -I$(EXEROOT)/gptl -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include
+LIBS += -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -lpio -lpnetcdf -lnetcdf
+
+all:
+ @echo $(CPPINCLUDES)
+ @echo $(FCINCLUDES)
+ ( $(MAKE) mpas RM="$(RM)" CPP="$(CPP)" NETCDF="$(NETCDF)" PNETCDF="$(PNETCDF)" \
+ PIO="$(PIO)" FC="$(FC)" CC="$(CC)" SFC="$(SFC)" SCC="$(SCC)" \
+ CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" FCINCLUDES="$(FCINCLUDES)" )
+
+mpas: reg_includes externals frame ops dycore drver
+ ar ru lib$(CORE).a framework/*.o
+ ar ru lib$(CORE).a operators/*.o
+ ar ru lib$(CORE).a core_$(CORE)/*.o
+ ar ru lib$(CORE).a $(CORE)_cesm_driver/*.o
+
+externals:
+
+drver: reg_includes externals frame ops dycore
+ ( cd $(CORE)_cesm_driver; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all )
+
Modified: branches/ocean_projects/shared_advection/src/core_hyd_atmos/Registry
===================================================================
--- branches/ocean_projects/shared_advection/src/core_hyd_atmos/Registry 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_hyd_atmos/Registry 2013-03-08 17:10:33 UTC (rev 2572)
@@ -96,7 +96,7 @@
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 persistent real cellTangentPlane ( R3 TWO nCells ) 0 o cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
Modified: branches/ocean_projects/shared_advection/src/core_hyd_atmos/mpas_atmh_time_integration.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_hyd_atmos/mpas_atmh_time_integration.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_hyd_atmos/mpas_atmh_time_integration.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -276,7 +276,7 @@
block % mesh % areaCell % array (iCell) &
- block % state % time_levs(2) % state % pressure % array (block % mesh % nVertLevels + 1, 1) * &
block % mesh % areaCell % array (iCell)
- do k=1, block % mesh % nVertLevelsSolve
+ do k=1, block % mesh % nVertLevels ! Could be nVertLevelsSolve?
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) * &
@@ -1378,7 +1378,7 @@
end do
wdtn(:,nVertLevels+1) = 0.
- do k=1,grid % nVertLevelsSolve
+ do k=1,grid % nVertLevels ! Could be nVertLevelsSolve?
do iScalar=1,num_scalars
scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*h_old(k,iCell) &
+ dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) )/h_new(k,iCell)
Modified: branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/Registry
===================================================================
--- branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/Registry 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/Registry 2013-03-08 17:10:33 UTC (rev 2572)
@@ -8,6 +8,9 @@
namelist integer nhyd_model config_theta_adv_order 3
namelist real nhyd_model config_coef_3rd_order 0.25
namelist integer nhyd_model config_num_halos 2
+namelist character dcmip config_dcmip_case 2-0-0
+namelist real dcmip config_planet_scale 1.0
+namelist real dcmip config_rotation_rate_scale 1.0
namelist integer dimensions config_nvertlevels 26
namelist integer dimensions config_nsoillevels 4
namelist integer dimensions config_nfglevels 27
@@ -105,7 +108,7 @@
var persistent real edgeNormalVectors ( R3 nEdges ) 0 io edgeNormalVectors mesh - -
var persistent real localVerticalUnitVectors ( R3 nCells ) 0 io localVerticalUnitVectors mesh - -
-var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 io cellTangentPlane mesh - -
+var persistent real cellTangentPlane ( R3 TWO nCells ) 0 io cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 io cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 io verticesOnCell mesh - -
Modified: branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/mpas_init_atm_mpas_core.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/mpas_init_atm_mpas_core.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/mpas_init_atm_mpas_core.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -22,6 +22,7 @@
block => domain % blocklist
do while (associated(block))
block % state % time_levs(1) % state % xtime % scalar = startTimeStamp
+ block % mesh % sphere_radius = a / config_planet_scale
block => block % next
end do
Modified: branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -121,14 +121,61 @@
block_ptr => block_ptr % next
end do
+ else if (config_test_case == 9 ) then
+
+ write(0,*) ' '
+ write(0,*) ' '
+ write(0,*) ' Setting up DCMIP test case '//trim(config_dcmip_case)
+ write(0,*) ' '
+ write(0,*) ' '
+
+ if (trim(config_dcmip_case) == '2-0-0' .or. &
+ trim(config_dcmip_case) == '2-0-1') then
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call init_atm_test_case_resting_atmosphere(block_ptr % mesh, block_ptr % state % time_levs(1) % state, &
+ block_ptr % diag, config_test_case)
+ block_ptr => block_ptr % next
+ end do
+
+ else if (trim(config_dcmip_case) == '2-1' .or. &
+ trim(config_dcmip_case) == '2-1a' .or. &
+ trim(config_dcmip_case) == '2-2' .or. &
+ trim(config_dcmip_case) == '3-1') then
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call init_atm_test_case_reduced_radius(block_ptr % mesh, block_ptr % state % time_levs(1) % state, &
+ block_ptr % diag, config_test_case)
+ block_ptr => block_ptr % next
+ end do
+
+ else
+
+ write(0,*) ' '
+ write(0,*) ' *************'
+ write(0,*) ' Unrecognized DCMIP case '//trim(config_dcmip_case)
+ write(0,*) ' Please choose either 2-0-0, 2-0-1, 2-1, 2-1a, 2-2, or 3-1'
+ write(0,*) ' *************'
+ write(0,*) ' '
+ call mpas_dmpar_abort(domain % dminfo)
+
+ end if
+
else
- write(0,*) ' Only test cases 1, 2, 3, 4, 5, 6, 7, and 8 are currently supported for nonhydrostatic core '
- stop
+ write(0,*) ' '
+ write(0,*) ' *************'
+ write(0,*) ' Only test cases 1 through 9 are currently supported for the nonhydrostatic core'
+ write(0,*) ' *************'
+ write(0,*) ' '
+ call mpas_dmpar_abort(domain % dminfo)
end if
+ ! Copy initialized state to all time levels
block_ptr => domain % blocklist
do while (associated(block_ptr))
do i=2,nTimeLevs
@@ -166,7 +213,10 @@
real (kind=RKIND), parameter :: u0 = 35.0
real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
- real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+
+! real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND) :: omega_e
+
real (kind=RKIND), parameter :: t0b = 250., t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
real (kind=RKIND), parameter :: theta_c = pii/4.0
@@ -229,23 +279,25 @@
real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2
logical, parameter :: moisture = .true.
+! logical, parameter :: moisture = .false.
+
!
- ! Scale all distances and areas from a unit sphere to one with radius a
+ ! Scale all distances and areas from a unit sphere to one with radius sphere_radius
!
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- 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
+ grid % xCell % array = grid % xCell % array * grid % sphere_radius
+ grid % yCell % array = grid % yCell % array * grid % sphere_radius
+ grid % zCell % array = grid % zCell % array * grid % sphere_radius
+ grid % xVertex % array = grid % xVertex % array * grid % sphere_radius
+ grid % yVertex % array = grid % yVertex % array * grid % sphere_radius
+ grid % zVertex % array = grid % zVertex % array * grid % sphere_radius
+ grid % xEdge % array = grid % xEdge % array * grid % sphere_radius
+ grid % yEdge % array = grid % yEdge % array * grid % sphere_radius
+ grid % zEdge % array = grid % zEdge % array * grid % sphere_radius
+ grid % dvEdge % array = grid % dvEdge % array * grid % sphere_radius
+ grid % dcEdge % array = grid % dcEdge % array * grid % sphere_radius
+ grid % areaCell % array = grid % areaCell % array * grid % sphere_radius**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * grid % sphere_radius**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * grid % sphere_radius**2.0
weightsOnEdge => grid % weightsOnEdge % array
nEdgesOnEdge => grid % nEdgesOnEdge % array
@@ -311,7 +363,8 @@
znut = eta_t
etavs = (1.-0.252)*pii/2.
- r_earth = a
+ r_earth = grid % sphere_radius
+ omega_e = omega * config_rotation_rate_scale
p0 = 1.e+05
write(0,*) ' point 1 in test case setup '
@@ -518,9 +571,14 @@
ppi(1) = ppi(1)-ppb(1,i)
do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv_2d(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv_2d(k+1,i))
+
+! ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
+! (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv_2d(k ,i) &
+! +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv_2d(k+1,i))
+
+ ppi(k+1) = ppi(k)-dzu(k+1)*gravity* &
+ ( (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv_2d(k ,i))*fzp(k+1) &
+ + (rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv_2d(k+1,i))*fzm(k+1) )
end do
do k=1,nz1
@@ -550,7 +608,7 @@
end do
call init_atm_recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz_2d,zx_2d, &
- cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat)
+ cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat,grid%sphere_radius)
end if
@@ -651,9 +709,15 @@
ppi(1) = ppi(1)-ppb(1,i)
do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
+
+! ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
+! (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
+! +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
+
+ ppi(k+1) = ppi(k)-dzu(k+1)*gravity* &
+ ( (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i))*fzp(k+1) &
+ + (rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))*fzm(k+1) )
+
end do
do k=1,nz1
@@ -701,24 +765,24 @@
lat2 = grid%latVertex%array(vtx2)
iCell1 = grid % cellsOnEdge % array(1,iEdge)
iCell2 = grid % cellsOnEdge % array(2,iEdge)
- flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
+ flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1))) * grid % sphere_radius / grid % dvEdge % array(iEdge)
if (config_test_case == 2) then
r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
lat_pert, lon_pert, 1.0_RKIND)/(pert_radius)
- u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
+ u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1) * grid % sphere_radius / grid % dvEdge % array(iEdge)
else if (config_test_case == 3) then
lon_Edge = grid % lonEdge % array(iEdge)
u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) &
- *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
+ *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1))) * grid % sphere_radius / grid % dvEdge % array(iEdge)
else
u_pert = 0.0
end if
if (rebalance) then
- call init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,grid % dvEdge % array(iEdge),a,u0,nz1,nlat)
+ call init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,grid % dvEdge % array(iEdge),grid%sphere_radius,u0,nz1,nlat)
do k=1,grid % nVertLevels
fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2)))
state % u % array(k,iEdge) = fluxk + u_pert
@@ -744,14 +808,14 @@
! Generate rotated Coriolis field
!
- grid % fEdge % array(iEdge) = 2.0 * omega * &
+ grid % fEdge % array(iEdge) = 2.0 * omega_e * &
( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha_grid) + &
sin(grid%latEdge%array(iEdge)) * cos(alpha_grid) &
)
end do
do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
+ grid % fVertex % array(iVtx) = 2.0 * omega_e * &
(-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha_grid) + &
sin(grid%latVertex%array(iVtx)) * cos(alpha_grid) &
)
@@ -778,11 +842,18 @@
d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
- end do
+! WCS fix 20120711
+
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ if ( grid % CellsOnCell % array (i,cell1) > 0) &
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ if ( grid % CellsOnCell % array (i,cell2) > 0) &
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
- (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
@@ -871,6 +942,7 @@
end subroutine init_atm_test_case_jw
+
subroutine init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1_in,lat2_in,dvEdge,a,u0,nz1,nlat)
implicit none
@@ -920,9 +992,11 @@
end subroutine init_atm_calc_flux_zonal
+
+
!SHP-balance
subroutine init_atm_recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz_2d,zx_2d, &
- cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat)
+ cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat,rad)
implicit none
integer, intent(in) :: nz1,nlat
@@ -931,18 +1005,21 @@
real (kind=RKIND), dimension(nz1,nlat-1), intent(in) :: zx_2d
real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d
real (kind=RKIND), dimension(nz1), intent(in) :: fzm, fzp, rdzw
- real (kind=RKIND), intent(in) :: cf1, cf2, cf3, dlat
+ real (kind=RKIND), intent(in) :: cf1, cf2, cf3, dlat, rad
!local variable
real (kind=RKIND), dimension(nz1,nlat-1) :: pgrad, ru, u
real (kind=RKIND), dimension(nlat-1) :: f
real (kind=RKIND), dimension(nz1+1) :: dpzx
- real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+! real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND) :: omega_e
+
real (kind=RKIND) :: rdx, qtot, r_earth, phi
integer :: k,i, itr
- r_earth = a
+ r_earth = rad
+ omega_e = omega * config_rotation_rate_scale
rdx = 1./(dlat*r_earth)
do i=1,nlat-1
@@ -1012,10 +1089,9 @@
u_2d(k,i) = (3.*u_2d(k,i-1)-u_2d(k,i-2))*.5
end do
-
end subroutine init_atm_recompute_geostrophic_wind
-!----------------------------------------------------------------------------------------------------------
+
subroutine init_atm_test_case_squall_line(dminfo, grid, state, diag, test_case)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Setup squall line and supercell test case
@@ -1999,7 +2075,7 @@
write(0,*) ' *** sounding for the simulation ***'
write(0,*) ' z theta pres qv rho_m u rr'
do k=1,nz1
- write(6,'(8(f14.9,2x))') .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
+ write(0,'(8(f14.9,2x))') .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
.01*p0*p(k,1)**(1./rcp), &
1000.*scalars(index_qv,k,1), &
@@ -2179,7 +2255,10 @@
real (kind=RKIND), parameter :: u0 = 35.0
real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
- real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+
+! real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND) :: omega_e
+
real (kind=RKIND), parameter :: t0b = 250., t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
real (kind=RKIND), parameter :: theta_c = pii/4.0
@@ -2338,7 +2417,8 @@
etavs = (1.-0.252)*pii/2.
rcv = rgas/(cp-rgas)
- r_earth = a
+ r_earth = grid % sphere_radius
+ omega_e = omega
p0 = 1.e+05
interp_list(1) = FOUR_POINT
@@ -2347,25 +2427,25 @@
!
- ! Scale all distances and areas from a unit sphere to one with radius a
+ ! Scale all distances and areas from a unit sphere to one with radius sphere_radius
!
if (config_static_interp) then
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- 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
+ grid % xCell % array = grid % xCell % array * r_earth
+ grid % yCell % array = grid % yCell % array * r_earth
+ grid % zCell % array = grid % zCell % array * r_earth
+ grid % xVertex % array = grid % xVertex % array * r_earth
+ grid % yVertex % array = grid % yVertex % array * r_earth
+ grid % zVertex % array = grid % zVertex % array * r_earth
+ grid % xEdge % array = grid % xEdge % array * r_earth
+ grid % yEdge % array = grid % yEdge % array * r_earth
+ grid % zEdge % array = grid % zEdge % array * r_earth
+ grid % dvEdge % array = grid % dvEdge % array * r_earth
+ grid % dcEdge % array = grid % dcEdge % array * r_earth
+ grid % areaCell % array = grid % areaCell % array * r_earth**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * r_earth**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * r_earth**2.0
scalars(:,:,:) = 0.
@@ -3204,9 +3284,7 @@
tempField % prev => null()
tempField % next => null()
- call mpas_timer_start("EXCHANGE_1D_REAL")
call mpas_dmpar_exch_halo_field(tempField)
- call mpas_timer_stop("EXCHANGE_1D_REAL")
! dzmina = minval(hs(:)-hx(k-1,:))
dzmina = minval(zw(k)+ah(k)*hs(1:grid%nCellsSolve)-zw(k-1)-ah(k-1)*hx(k-1,1:grid%nCellsSolve))
@@ -4308,6 +4386,7 @@
end subroutine init_atm_test_case_gfs
+
subroutine init_atm_test_case_sfc(domain, dminfo, grid, fg, state, diag, test_case, parinfo)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Real-data test case using SST data
@@ -4544,6 +4623,1583 @@
end subroutine init_atm_test_case_sfc
+!--------------------- TEST CASE 9 -----------------------------------------------
+
+
+ subroutine init_atm_test_case_reduced_radius(grid, state, diag, test_case)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup Schar-type mountain wave test case on reduced radius sphere
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+ type (diag_type), intent(inout) :: diag
+ integer, intent(in) :: test_case
+
+ real (kind=RKIND), parameter :: t0=300., hm=250., alpha=0.
+! real (kind=RKIND), parameter :: t0=288., hm=0., alpha=0.
+
+ ! Parameters for test case 3-1
+ real (kind=RKIND), parameter :: widthParm = 5000.0, &
+ dTheta = 1.0, &
+ L_z = 20000.0, &
+ theta_c = 0.0, &
+ lambda_c = 2.0 * pii / 3.0
+
+
+ real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
+ real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
+ real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zb, zb3
+
+ !This is temporary variable here. It just need when calculate tangential velocity v.
+ integer :: eoe, j
+ integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell
+ integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge, edgesOnCell
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, AreaCell, xCell, yCell, dcEdge
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
+
+ integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, kz, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
+ integer :: index_qv
+
+ real (kind=RKIND) :: ptop, p0, pis, flux, d2fdx2_cell1, d2fdx2_cell2
+
+ real (kind=RKIND) :: ztemp, zd, zt, dz, str
+ real(kind=RKIND), dimension(:), pointer :: hs, hs1
+
+ real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh
+ real (kind=RKIND) :: es, qvs, xnutr, ptemp
+ integer :: iter, nsm
+ integer, dimension(:,:), pointer :: cellsOnCell
+
+ type (field1DReal), pointer :: tempField
+ type (field1DReal), target :: tempFieldTarget
+
+ type (block_type), pointer :: block
+ type (parallel_info), pointer :: parinfo
+ type (dm_info), pointer :: dminfo
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+ real (kind=RKIND) :: d1, d2, d3, cof1, cof2, cf1, cf2, cf3
+ real (kind=RKIND) :: um, us, rcp, rcv
+ real (kind=RKIND) :: xmid, temp, pres, a_scale, xac, xlac, shear, tsurf, usurf
+
+ real (kind=RKIND) :: xi, yi, ri, xa, xc, yc, xla, zinv, xn2, xn2m, xn2l, sm, dzh, dzht, dzmin, dzmina, dzminf, &
+ dzmina_global, z_edge, z_edge3, sm0
+ real (kind=RKIND) :: theta_pert, s
+
+ integer, dimension(grid % nCells, 2) :: next_cell
+ real (kind=RKIND), dimension(grid % nCells) :: hxzt, pitop, ptopb
+ logical, parameter :: terrain_smooth = .false.
+
+ block => grid % block
+ parinfo => block % parinfo
+ dminfo => block % domain % dminfo
+
+
+ !
+ ! Scale all distances
+ !
+ a_scale = grid % sphere_radius
+
+ grid % xCell % array = grid % xCell % array * a_scale
+ grid % yCell % array = grid % yCell % array * a_scale
+ grid % zCell % array = grid % zCell % array * a_scale
+ grid % xVertex % array = grid % xVertex % array * a_scale
+ grid % yVertex % array = grid % yVertex % array * a_scale
+ grid % zVertex % array = grid % zVertex % array * a_scale
+ grid % xEdge % array = grid % xEdge % array * a_scale
+ grid % yEdge % array = grid % yEdge % array * a_scale
+ grid % zEdge % array = grid % zEdge % array * a_scale
+ grid % dvEdge % array = grid % dvEdge % array * a_scale
+ grid % dcEdge % array = grid % dcEdge % array * a_scale
+ grid % areaCell % array = grid % areaCell % array * a_scale**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ dvEdge => grid % dvEdge % array
+ dcEdge => grid % dcEdge % array
+ AreaCell => grid % AreaCell % array
+ CellsOnEdge => grid % CellsOnEdge % array
+ cellsOnCell => grid % cellsOnCell % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ deriv_two => grid % deriv_two % array
+
+ nz1 = grid % nVertLevels
+ nz = nz1 + 1
+ nCellsSolve = grid % nCellsSolve
+
+ zgrid => grid % zgrid % array
+ zb => grid % zb % array
+ zb3 => grid % zb3 % array
+ rdzw => grid % rdzw % array
+ dzu => grid % dzu % array
+ rdzu => grid % rdzu % array
+ fzm => grid % fzm % array
+ fzp => grid % fzp % array
+ zx => grid % zx % array
+ zz => grid % zz % array
+ hx => grid % hx % array
+ dss => grid % dss % array
+
+ xCell => grid % xCell % array
+ yCell => grid % yCell % array
+
+ ppb => diag % pressure_base % array
+ pb => diag % exner_base % array
+ rb => diag % rho_base % array
+ tb => diag % theta_base % array
+ rtb => diag % rtheta_base % array
+ p => diag % exner % array
+ cqw => diag % cqw % array
+
+ rho_zz => state % rho_zz % array
+
+ pp => diag % pressure_p % array
+ rr => diag % rho_p % array
+ t => state % theta_m % array
+ rt => diag % rtheta_p % array
+ u => state % u % array
+ ru => diag % ru % array
+
+ scalars => state % scalars % array
+
+ index_qv = state % index_qv
+
+ scalars(:,:,:) = 0.
+
+ call atm_initialize_advection_rk(grid)
+ call atm_initialize_deformation_weights(grid)
+
+ if (trim(config_dcmip_case) == '2-1') then
+ zt = 30000.
+ xnutr = 0.1 ! Coefficient for implicit w damping in absorbing layer
+ zd = 20000. ! Bottom of absorbing layer
+ write(0,*) ' test case 2-1, zt, zd, xnutr ', zt,zd,xnutr
+ end if
+
+ if (trim(config_dcmip_case) == '2-1a') then
+ zt = 20000.
+ xnutr = 0.1 ! Coefficient for implicit w damping in absorbing layer
+ zd = 10000. ! Bottom of absorbing layer
+ write(0,*) ' test case 2-1a, zt, zd, xnutr ', zt,zd,xnutr
+ end if
+
+ if (trim(config_dcmip_case) == '2-2') then
+ zt = 30000.
+ xnutr = 0.1 ! Coefficient for implicit w damping in absorbing layer
+ zd = 20000. ! Bottom of absorbing layer
+ write(0,*) ' test case 2-2, zt, zd, xnutr ', zt,zd,xnutr
+ end if
+
+ if (trim(config_dcmip_case) == '3-1') then
+ zt = 10000.
+ xnutr = 0.0 ! Coefficient for implicit w damping in absorbing layer
+ zd = 10000. ! Bottom of absorbing layer
+ write(0,*) ' test case 3-1, zt, zd, xnutr ', zt,zd,xnutr
+ end if
+
+ p0 = 1.e+05
+ rcp = rgas/cp
+ rcv = rgas/(cp-rgas)
+
+ ! metrics for hybrid coordinate and vertical stretching
+ str = 1.0
+
+
+ dz = zt/float(nz1)
+! write(0,*) ' dz = ',dz
+
+ do k=1,nz
+
+! sh(k) is the stretching specified for height surfaces
+
+ zc(k) = zt*(real(k-1)*dz/zt)**str
+
+! to specify specific heights zc(k) for coordinate surfaces,
+! input zc(k)
+! zw(k) is the hieght of zeta surfaces
+! zw(k) = (k-1)*dz yields constant dzeta
+! and nonconstant dzeta/dz
+! zw(k) = sh(k)*zt yields nonconstant dzeta
+! and nearly constant dzeta/dz
+
+! zw(k) = float(k-1)*dz
+ zw(k) = zc(k)
+!
+! ah(k) governs the transition between terrain-following
+! and pureheight coordinates
+! ah(k) = 0 is a terrain-following coordinate
+! ah(k) = 1 is a height coordinate
+
+! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
+ ah(k) = 1.
+! write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)
+ end do
+ do k=1,nz1
+ dzw (k) = zw(k+1)-zw(k)
+ rdzw(k) = 1./dzw(k)
+ zu(k ) = .5*(zw(k)+zw(k+1))
+ end do
+ do k=2,nz1
+ dzu (k) = .5*(dzw(k)+dzw(k-1))
+ rdzu(k) = 1./dzu(k)
+ fzp (k) = .5* dzw(k )/dzu(k)
+ fzm (k) = .5* dzw(k-1)/dzu(k)
+ rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
+ rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
+ end do
+
+!********** how are we storing cf1, cf2 and cf3?
+
+ d1 = .5*dzw(1)
+ d2 = dzw(1)+.5*dzw(2)
+ d3 = dzw(1)+dzw(2)+.5*dzw(3)
+ !cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+ !cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+ !cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+
+ cof1 = (2.*dzu(2)+dzu(3))/(dzu(2)+dzu(3))*dzw(1)/dzu(2)
+ cof2 = dzu(2) /(dzu(2)+dzu(3))*dzw(1)/dzu(3)
+ cf1 = fzp(2) + cof1
+ cf2 = fzm(2) - cof1 - cof2
+ cf3 = cof2
+
+ grid % cf1 % scalar = cf1
+ grid % cf2 % scalar = cf2
+ grid % cf3 % scalar = cf3
+
+ write(0,*) 'EARTH RADIUS = ', grid % sphere_radius
+
+! setting for terrain
+
+! MGD for both 2-1 and 2-1a (and 2-2)
+ if (trim(config_dcmip_case) == '2-1' .or. &
+ trim(config_dcmip_case) == '2-1a' .or. &
+ trim(config_dcmip_case) == '2-2') then
+ xa = 5000.
+ xla = 4000.
+ end if
+
+ write(0,*) ' hm, xa, xla ',hm,xa,xla
+
+ hx = 0.
+
+ do iCell=1,grid % nCells
+
+ xi = grid % lonCell % array(iCell)
+ yi = grid % latCell % array(iCell)
+ xc = sphere_distance(yi, xi, yi, 0., grid % sphere_radius)
+ yc = sphere_distance(yi, xi, 0., xi, grid % sphere_radius)
+ xac = sphere_distance(yi, xa /grid % sphere_radius, yi, 0., grid % sphere_radius)
+ xlac = sphere_distance(yi, xla/grid % sphere_radius, yi, 0., grid % sphere_radius)
+
+ ri = sphere_distance(yi, xi, 0., 0., grid % sphere_radius)
+
+! MGD BEGIN 2-1
+! Circular mountain with Schar mtn cross section
+ if (trim(config_dcmip_case) == '2-1') then
+ hx(1,iCell) = hm*exp(-(ri/xa)**2)*cos(pii*ri/xla)**2
+ end if
+! MGD END 2-1
+
+! MGD BEGIN 2-2
+! Circular mountain with Schar mtn cross section
+ if (trim(config_dcmip_case) == '2-2') then
+ hx(1,iCell) = hm*exp(-(ri/xa)**2)*cos(pii*ri/xla)**2
+ end if
+! MGD END 2-2
+
+! MGD BEGIN 2-1a
+! proposed to be run with x333 rather than x500
+! Ridge mountain with Schar mtn cross section
+ if (trim(config_dcmip_case) == '2-1a') then
+ hx(1,iCell) = hm*exp(-(xc/xac)**2)*cos(pii*xc/xlac)**2*cos(yc/grid % sphere_radius)
+ end if
+! MGD END 2-1a
+
+ hx(nz,iCell) = zt
+
+
+ enddo
+ write(0,*) ' hx computation complete '
+
+!!! MGD WE NEED TO REPLACE THIS TERRAIN SMOOTHING WITH TC9
+
+ kz = nz
+
+ if (config_smooth_surfaces) then
+
+ write(0,*) ' '
+ write(0,*) ' Smoothing vertical coordinate surfaces'
+ write(0,*) ' '
+
+ allocate(hs (grid % nCells+1))
+ allocate(hs1(grid % nCells+1))
+
+ dzmin = 0.5
+ sm0 = 0.5
+ nsm = 30
+
+ write(6,*) 'dzmin = ',dzmin,' sm0 = ',sm0,' nsm = ',nsm
+
+ do k=2,kz-1
+ hx(k,:) = hx(k-1,:)
+ dzminf = zw(k)-zw(k-1)
+
+! dzmin = max(0.5_RKIND,1.-.5*zw(k)/hm)
+
+ sm = sm0*max( min(.5*zw(k)/hm,1.0_RKIND), .05 )
+
+ do i=1,nsm
+ do iCell=1,grid % nCells
+ hs1(iCell) = 0.
+ do j = 1,nEdgesOnCell(iCell)
+
+ hs1(iCell) = hs1(iCell) + dvEdge(edgesOnCell(j,iCell)) &
+ / dcEdge(edgesOnCell(j,iCell)) &
+ * (hx(k,cellsOnCell(j,iCell))-hx(k,iCell))
+ end do
+ hs1(iCell) = hx(k,iCell) + sm*hs1(iCell)
+
+ hs(iCell) = 0.
+ ! do j = 1,nEdgesOnCell(iCell)
+ ! hs(iCell) = hs(iCell) + dvEdge(edgesOnCell(j,iCell)) &
+ ! / dcEdge(edgesOnCell(j,iCell)) &
+ ! * (hs1(cellsOnCell(j,iCell))-hs1(iCell))
+ ! end do
+ hs(iCell) = hs1(iCell) - 0.*hs(iCell)
+
+ end do
+
+ tempField => tempFieldTarget
+ tempField % block => block
+ tempField % dimSizes(1) = grid % nCells
+ tempField % sendList => parinfo % cellsToSend
+ tempField % recvList => parinfo % cellsToRecv
+ tempField % copyList => parinfo % cellsToCopy
+ tempField % array => hs
+ tempField % prev => null()
+ tempField % next => null()
+
+ call mpas_dmpar_exch_halo_field(tempField)
+
+ ! dzmina = minval(hs(:)-hx(k-1,:))
+ dzmina = minval(zw(k)+ah(k)*hs(1:grid%nCellsSolve)-zw(k-1)-ah(k-1)*hx(k-1,1:grid%nCellsSolve))
+ call mpas_dmpar_min_real(dminfo, dzmina, dzmina_global)
+ ! write(0,*) ' k,i, dzmina, dzmin, zw(k)-zw(k-1) ', k,i, dzmina, dzmin, zw(k)-zw(k-1)
+ if (dzmina_global >= dzmin*(zw(k)-zw(k-1))) then
+ hx(k,:)=hs(:)
+ dzminf = dzmina_global
+ else
+ exit
+ end if
+ end do
+ write(0,*) k,i,sm,dzminf/(zw(k)-zw(k-1)),dzmina/(zw(k)-zw(k-1))
+ end do
+
+ do k=kz,nz
+ hx(k,:) = 0.
+ end do
+
+ deallocate(hs )
+ deallocate(hs1)
+
+ else
+
+ do k=2,nz1
+ dzmina = minval(zw(k)+ah(k)*hx(k,:)-zw(k-1)-ah(k-1)*hx(k-1,:))
+ write(0,*) k,dzmina/(zw(k)-zw(k-1))
+ end do
+
+ end if
+
+
+ do iCell=1,grid % nCells
+ do k=1,nz
+ if (config_smooth_surfaces) then
+ zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
+ + (1.-ah(k)) * zc(k)
+ else
+ zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(1,iCell)/zt)+hx(1,iCell)) &
+ + (1.-ah(k)) * zc(k)
+ end if
+ end do
+ do k=1,nz1
+ zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
+ end do
+ end do
+
+ do i=1, grid % nEdges
+ iCell1 = grid % CellsOnEdge % array(1,i)
+ iCell2 = grid % CellsOnEdge % array(2,i)
+ do k=1,nz
+ zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
+ end do
+ end do
+ do i=1, grid % nCells
+ do k=1,nz1
+ ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
+ dss(k,i) = 0.
+ ztemp = zgrid(k,i)
+ if(ztemp.gt.zd+.1) then
+ dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
+ end if
+ end do
+ enddo
+
+ write(0,*) ' grid metrics setup complete '
+
+!
+! mountain wave initialization
+!
+!MGD BEGIN 3-1
+! Coefficients used to initialize 2 layer sounding based on stability
+ if (trim(config_dcmip_case) == '3-1') then
+ zinv = 3000. ! Height of lower layer
+ xn2 = 0.0001 ! N^2 for upper layer
+ xn2m = 0.0001 ! N^2 for reference sounding
+ xn2l = 0.0001 ! N^@ for lower layer
+ end if
+!MGD END 3-1
+
+ if (trim(config_dcmip_case) == '2-1' .or. &
+ trim(config_dcmip_case) == '2-1a' .or. &
+ trim(config_dcmip_case) == '2-2' .or. &
+ trim(config_dcmip_case) == '3-1') then
+ um = 20. ! base wind for 2-1, 2-1a, 2-2, and 3-1
+ end if
+
+ if (trim(config_dcmip_case) == '2-2') then
+ shear = 0.00025 ! MGD 2-2
+ else
+ shear = 0. ! MGD everything else, 2-1, ...
+ end if
+
+ do i=1,grid % nCells
+
+! Surface temp and Exner function as function of latitude to balance wind fed
+
+ tsurf = t0*exp(-shear*um**2/gravity*sin(grid%latCell%array(i))**2)
+ pis = exp(-um**2*sin(grid%latCell%array(i))**2/(2.*cp*tsurf))
+
+ do k=1,nz1
+ ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
+
+!MGD FOR 2-1, 2-1a, 2-2
+! Isothermal temerature initialization
+ if (trim(config_dcmip_case) == '2-1' .or. &
+ trim(config_dcmip_case) == '2-1a' .or. &
+ trim(config_dcmip_case) == '2-2') then
+
+ t (k,i) = tsurf/pis*exp(gravity*ztemp/(cp*tsurf))
+ tb (k,i) = t0*exp(gravity*ztemp/(cp*t0))
+!! JBK fix, 20120801
+ !! tb(k,i) = t(k,i)
+
+ end if
+
+!MGD FOR 3-1
+! Initialization based on stability
+ if (trim(config_dcmip_case) == '3-1') then
+ if(ztemp .le. zinv) then
+ t (k,i) = t0*(1.+xn2l/gravity*ztemp)
+ else
+ t (k,i) = t0*(1.+xn2l/gravity*zinv+xn2/gravity*(ztemp-zinv))
+ end if
+ tb(k,i) = t0*(1. + xn2m/gravity*ztemp)
+ end if
+
+ rh(k,i) = 0.
+ end do
+
+
+! MGD ADD CODE HERE FOR 3-1 THERMAL PERT
+ if (trim(config_dcmip_case) == '3-1') then
+ do k=1,nz1
+ s = widthParm**2.0 / (widthParm**2.0 + sphere_distance(theta_c, lambda_c, &
+ grid%latCell%array(i), grid%lonCell%array(i), &
+ grid%sphere_radius)**2.0)
+ theta_pert = dTheta * s * sin((2.0_RKIND * pii * 0.5*(zgrid(k,i)+zgrid(k+1,i))) / L_z)
+ ! diag % theta % array(k,i) = diag % theta % array(k,i) + theta_pert
+ t(k,i) = t(k,i) + theta_pert
+ end do
+ end if
+
+
+
+ end do
+
+ !
+ ! Initialize wind field
+ !
+ allocate(psiVertex(grid % nVertices))
+ do iVtx=1,grid % nVertices
+ psiVertex(iVtx) = -grid % sphere_radius * um * ( &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
+ cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
+ )
+ end do
+ do iEdge=1,grid % nEdges
+ cell1 = grid % CellsOnEdge % array(1,iEdge)
+ cell2 = grid % CellsOnEdge % array(2,iEdge)
+ usurf = -1.0 * ( &
+ psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
+ psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
+ ) / grid%dvEdge%array(iEdge)
+ do k=1,nz1
+ ztemp = .25*( zgrid(k,cell1)+zgrid(k+1,cell1 ) &
+ +zgrid(k,cell2)+zgrid(k+1,cell2))
+
+! Top of shear layer set at 10 km
+! if(ztemp.lt.10000.) then
+ u(k,iEdge) = usurf * sqrt(1.+2.*shear*ztemp)
+! else
+! u(k,iEdge) = usurf * sqrt(1.+2.*shear*10000.)
+! end if
+ end do
+ end do
+ deallocate(psiVertex)
+
+ do k=1,nz1
+ ztemp = .5*( zw(k)+zw(k+1))
+! if(ztemp.lt.10000.) then
+ grid % u_init % array(k) = um * sqrt(1.+2.*shear*ztemp)
+! else
+! grid % u_init % array(k) = um * sqrt(1.+2.*shear*10000.)
+! end if
+ end do
+
+!
+! reference sounding based on dry atmosphere
+!
+ do i=1, grid % nCells
+
+ tsurf = t0*exp(-shear*um**2/gravity*sin(grid%latCell%array(i))**2)
+
+!! JBK fix 20120801
+!! pis = exp(-um**2*sin(grid%latCell%array(i))**2/(2.*cp*tsurf))
+ pis = 1.
+
+ pitop(i) = pis-.5*dzw(1)*gravity/(cp*tb(1,1)*zz(1,1))
+ do k=2,nz1
+ pitop(i) = pitop(i)-dzu(k)*gravity/(cp*(fzm(k)*tb(k,1)+fzp(k)*tb(k-1,1)) &
+ *(fzm(k)*zz(k,1)+fzp(k)*zz(k-1,1)))
+ end do
+ pitop(i) = pitop(i)-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1))
+ ptopb(i) = p0*pitop(i)**(1./rcp)
+
+ pb(nz1,i) = pitop(i)+.5*dzw(nz1)*gravity/(cp*tb(nz1,i)*zz(nz1,i))
+ p (nz1,i) = pitop(i)+.5*dzw(nz1)*gravity/(cp*t (nz1,i)*zz(nz1,i))
+ do k=nz1-1,1,-1
+ pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*.5*(tb(k,i)+tb(k+1,i)) &
+ *.5*(zz(k,i)+zz(k+1,i)))
+ p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*.5*(t (k,i)+t (k+1,i)) &
+ *.5*(zz(k,i)+zz(k+1,i)))
+ end do
+ do k=1,nz1
+ rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
+ rtb(k,i) = rb(k,i)*tb(k,i)
+ rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
+ cqw(k,i) = 1.
+ end do
+ end do
+
+ write(0,*) ' ***** base state sounding ***** '
+ write(0,*) 'k pb p rb rtb rr tb t'
+ do k=1,grid%nVertLevels
+ write(0,'(i2,7(2x,f14.9))') k,pb(k,1),p(k,1),rb(k,1),rtb(k,1),rr(k,1),tb(k,1),t(k,1)
+ end do
+
+ scalars(index_qv,:,:) = 0.
+!!!
+!-------------------------------------------------------------------
+! ITERATIONS TO CONVERGE MOIST SOUNDING
+ do itr=1,30
+
+ do i = 1, grid % nCells
+
+ tsurf = t0*exp(-shear*um**2/gravity*sin(grid%latCell%array(i))**2)
+ pis = exp(-um**2*sin(grid%latCell%array(i))**2/(2.*cp*tsurf))
+! pis = 1.
+
+ pitop(i) = pis-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
+
+ do k=2,nz1
+ pitop(i) = pitop(i)-dzu(k)*gravity/(cp*cqw(k,1)*(fzm(k)*t (k,1)+fzp(k)*t (k-1,1)) &
+ *(fzm(k)*zz(k,1)+fzp(k)*zz(k-1,1)))
+ end do
+ pitop(i) = pitop(i) - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
+ ptop = p0*pitop(i)**(1./rcp)
+
+ pp(nz1,i) = ptop-ptopb(i)+.5*dzw(nz1)*gravity* &
+ (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
+ do k=nz1-1,1,-1
+ pp(k,i) = pp(k+1,i)+dzu(k+1)*gravity* &
+ (fzm(k)*(rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i)) &
+ +fzp(k)*(rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i)))
+ end do
+ do k=1,nz1
+ rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
+ -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
+ p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
+ rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
+ end do
+!
+! update water vapor mixing ratio from humitidty profile
+!
+ do k=1,nz1
+ temp = p(k,i)*t(k,i)
+ pres = p0*p(k,i)**(1./rcp)
+ qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
+ scalars(index_qv,k,i) = min(0.014_RKIND,rh(k,i)*qvs)
+ end do
+
+ do k=1,nz1
+ t (k,i) = t(k,i)*(1.+1.61*scalars(index_qv,k,i))
+ end do
+ do k=2,nz1
+ cqw(k,i) = 1./(1.+.5*( scalars(index_qv,k-1,i) &
+ +scalars(index_qv,k ,i)))
+ end do
+
+ end do ! loop over cells
+
+ end do ! iteration loop
+!----------------------------------------------------------------------
+!
+ write(0,*) ' *** sounding for the simulation ***'
+ write(0,*) ' z theta pres qv rho_m u rr'
+ do k=1,nz1
+ write(0,'(8(f14.9,2x))') .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
+ t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
+ .01*p0*p(k,1)**(1./rcp), &
+ 1000.*scalars(index_qv,k,1), &
+ (rb(k,1)+rr(k,1))*(1.+scalars(index_qv,k,1)), &
+ grid % u_init % array(k), rr(k,1)
+ end do
+
+ do i=1,grid % ncells
+ do k=1,nz1
+ rho_zz(k,i) = rb(k,i)+rr(k,i)
+ end do
+
+ do k=1,nz1
+ grid % t_init % array(k,i) = t(k,i)
+ end do
+ end do
+
+ do i=1,grid % nEdges
+ cell1 = grid % CellsOnEdge % array(1,i)
+ cell2 = grid % CellsOnEdge % array(2,i)
+ if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
+ do k=1,nz1
+ ru (k,i) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*u(k,i)
+ end do
+ end if
+ end do
+
+!
+! pre-calculation z-metric terms in omega eqn.
+!
+ do iEdge = 1,grid % nEdges
+ cell1 = CellsOnEdge(1,iEdge)
+ cell2 = CellsOnEdge(2,iEdge)
+ if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
+
+ do k = 1, grid%nVertLevels
+
+ if (config_theta_adv_order == 2) then
+!! test for metric consistency - forces 2nd order metrics with 4th order advection
+! if (config_theta_adv_order == 4) then
+
+ z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2.
+
+ else !theta_adv_order == 3 or 4
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ if ( grid % CellsOnCell % array (i,cell1) > 0) &
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ if ( grid % CellsOnCell % array (i,cell2) > 0) &
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
+ - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+
+ if (config_theta_adv_order == 3) then
+ z_edge3 = - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ else
+ z_edge3 = 0.
+ end if
+
+ end if
+
+ zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/AreaCell(cell1)
+ zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/AreaCell(cell2)
+ zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
+ zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
+
+! if (k /= 1) then
+! zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb(k,1,iEdge)
+! zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb(k,2,iEdge)
+! zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb3(k,1,iEdge)
+! zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb3(k,2,iEdge)
+! end if
+
+ end do
+
+ end if
+ end do
+
+! for including terrain
+ state % w % array(:,:) = 0.0
+ diag % rw % array(:,:) = 0.0
+
+!
+! calculation of omega, rw = zx * ru + zz * rw
+!
+
+! do iEdge = 1,grid % nEdges
+
+! cell1 = CellsOnEdge(1,iEdge)
+! cell2 = CellsOnEdge(2,iEdge)
+
+! if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
+! do k = 2, grid%nVertLevels
+! flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge))
+! diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
+! diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+
+! if (config_theta_adv_order ==3) then
+! diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
+! - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+! diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
+! + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+! end if
+
+! end do
+! end if
+
+! end do
+
+ ! Compute w from rho_zz and rw
+ do iCell=1,grid%nCells
+ do k=2,grid%nVertLevels
+ state % w % array(k,iCell) = diag % rw % array(k,iCell) &
+ / (fzp(k) * state % rho_zz % array(k-1,iCell) + fzm(k) * state % rho_zz % array(k,iCell))
+ end do
+ end do
+
+
+ do iEdge=1,grid % nEdges
+ grid % fEdge % array(iEdge) = 0.
+ end do
+
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 0.
+ end do
+
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ diag % v % array(:,:) = 0.0
+ do iEdge = 1, grid%nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ if (eoe > 0) then
+ do k = 1, grid%nVertLevels
+ diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
+ end do
+ end if
+ end do
+ end do
+
+! do k=1,grid%nVertLevels
+! write(0,*) ' k,u_init, t_init, qv_init ',k,grid % u_init % array(k),grid % t_init% array(k),grid % qv_init % array(k)
+! end do
+
+ ! Compute rho and theta from rho_zz and theta_m
+ do iCell=1,grid%nCells
+ do k=1,grid%nVertLevels
+ diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell))
+ end do
+ end do
+
+! MGD FOR 3-1:
+! zt = 10000.0
+! nVertLevels = 10
+! X = 125
+! dt = 12.
+! nso = 8
+! 2nd-order horiz mixing = 50.0
+
+ end subroutine init_atm_test_case_reduced_radius
+
+
+!--------------------- TEST CASE 9 -----------------------------------------------
+
+
+ subroutine init_atm_test_case_resting_atmosphere(grid, state, diag, test_case)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup resting atmosphere test case with terrian
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+ type (diag_type), intent(inout) :: diag
+ integer, intent(in) :: test_case
+
+ real (kind=RKIND), parameter :: t0=300., alpha=0.
+ real (kind=RKIND) :: hm
+
+ real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
+ real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
+ real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zb, zb3
+
+ !This is temporary variable here. It just need when calculate tangential velocity v.
+ integer :: eoe, j
+ integer, dimension(:), pointer :: nEdgesOnEdge
+ integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge, cellsOnCell, edgesOnCell
+ integer, dimension(:), pointer :: nEdgesOnCell
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, dcedge, AreaCell, xCell, yCell
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
+
+ integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
+ integer :: index_qv
+
+ real (kind=RKIND) :: ptop, p0, pis, flux, d2fdx2_cell1, d2fdx2_cell2
+ real(kind=RKIND), dimension(:), pointer :: hs, hs1
+
+ real (kind=RKIND) :: ztemp, zd, zt, dz, str, zh, hmax
+
+ real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh
+ real (kind=RKIND) :: es, qvs, xnutr, ptemp
+ integer :: iter, nsm, kz
+
+ type (field1DReal), pointer :: tempField
+ type (field1DReal), target :: tempFieldTarget
+
+ type (block_type), pointer :: block
+ type (parallel_info), pointer :: parinfo
+ type (dm_info), pointer :: dminfo
+
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
+ real (kind=RKIND), allocatable, dimension(:) :: psiVertex
+
+ real (kind=RKIND) :: d1, d2, d3, cof1, cof2, cf1, cf2, cf3
+ real (kind=RKIND) :: um, us, rcp, rcv, gamma, xa, zinb, zint, tinv, th_inb, th_int
+ real (kind=RKIND) :: xmid, temp, pres, a_scale, rad, shear, tsurf, usurf, sm0, dzmina, dzmina_global, dzminf
+
+ real (kind=RKIND) :: xi, yi, r1m, r2m, xc, yc, xla, zinv, xn2, xn2m, xn2l, sm, dzh, dzht, dzmin, z_edge, z_edge3
+
+ integer, dimension(grid % nCells, 2) :: next_cell
+ real (kind=RKIND), dimension(grid % nCells) :: pitop, ptopb
+ logical, parameter :: hybrid = .false.
+! logical, parameter :: hybrid = .true.
+
+ block => grid % block
+ parinfo => block % parinfo
+ dminfo => block % domain % dminfo
+
+
+ !
+ ! Scale all distances
+ !
+ a_scale = grid % sphere_radius
+
+ grid % xCell % array = grid % xCell % array * a_scale
+ grid % yCell % array = grid % yCell % array * a_scale
+ grid % zCell % array = grid % zCell % array * a_scale
+ grid % xVertex % array = grid % xVertex % array * a_scale
+ grid % yVertex % array = grid % yVertex % array * a_scale
+ grid % zVertex % array = grid % zVertex % array * a_scale
+ grid % xEdge % array = grid % xEdge % array * a_scale
+ grid % yEdge % array = grid % yEdge % array * a_scale
+ grid % zEdge % array = grid % zEdge % array * a_scale
+ grid % dvEdge % array = grid % dvEdge % array * a_scale
+ grid % dcEdge % array = grid % dcEdge % array * a_scale
+ grid % areaCell % array = grid % areaCell % array * a_scale**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ dvEdge => grid % dvEdge % array
+ dcEdge => grid % dcEdge % array
+ AreaCell => grid % AreaCell % array
+ CellsOnEdge => grid % CellsOnEdge % array
+ cellsOnCell => grid % cellsOnCell % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ deriv_two => grid % deriv_two % array
+
+ nz1 = grid % nVertLevels
+ nz = nz1 + 1
+ nCellsSolve = grid % nCellsSolve
+
+ zgrid => grid % zgrid % array
+ zb => grid % zb % array
+ zb3 => grid % zb3 % array
+ rdzw => grid % rdzw % array
+ dzu => grid % dzu % array
+ rdzu => grid % rdzu % array
+ fzm => grid % fzm % array
+ fzp => grid % fzp % array
+ zx => grid % zx % array
+ zz => grid % zz % array
+ hx => grid % hx % array
+ dss => grid % dss % array
+
+ xCell => grid % xCell % array
+ yCell => grid % yCell % array
+
+ ppb => diag % pressure_base % array
+ pb => diag % exner_base % array
+ rb => diag % rho_base % array
+ tb => diag % theta_base % array
+ rtb => diag % rtheta_base % array
+ p => diag % exner % array
+ cqw => diag % cqw % array
+
+ rho_zz => state % rho_zz % array
+
+ pp => diag % pressure_p % array
+ rr => diag % rho_p % array
+ t => state % theta_m % array
+ rt => diag % rtheta_p % array
+ u => state % u % array
+ ru => diag % ru % array
+
+ scalars => state % scalars % array
+
+ index_qv = state % index_qv
+
+ scalars(:,:,:) = 0.
+
+ call atm_initialize_advection_rk(grid)
+ call atm_initialize_deformation_weights(grid)
+
+ xnutr = 0.1
+ zd = 12000.
+
+ p0 = 1.e+05
+ rcp = rgas/cp
+ rcv = rgas/(cp-rgas)
+
+ ! metrics for hybrid coordinate and vertical stretching
+ str = 1.0
+
+ zt = 12000.
+
+ dz = zt/float(nz1)
+! write(0,*) ' dz = ',dz
+
+ do k=1,nz
+ zw(k) = (real(k-1)/real(nz1))**str*zt
+ if(k.gt.1) dzw(k-1) = zw(k)-zw(k-1)
+ end do
+
+! ah(k) governs the transition between terrain-following
+! and pure height coordinates
+! ah(k) = 1 is a smoothed terrain-following coordinate
+! ah(k) = 1.-zw(k)/zt is the basic terrain-following coordinate
+! ah(k) = 0 is a height coordinate
+
+ write(6,*) ' hybrid = ',hybrid
+ kz = nz
+
+ if(hybrid) then
+
+ zh = zt
+
+ do k=1,nz
+ if(zw(k).lt.zh) then
+
+! if(k.le.2) then
+! ah(k) = 1.
+! else
+! ah(k) = cos(.5*pii*(zw(k)-zw(2))/zh)**6
+! end if
+
+! ah(k) = cos(.5*pii*zw(k)/zh)**6
+ ah(k) = cos(.5*pii*zw(k)/zh)**2
+!
+! ah(k) = ah(k)*(1.-zw(k)/zt)
+!
+ else
+ ah(k) = 0.
+ kz = min(kz,k)
+ end if
+ end do
+
+ else
+
+ do k=1,nz
+ ah(k) = 1.-zw(k)/zt
+ end do
+
+ end if
+
+
+ do k=1,nz
+ write(6,*) k,zw(k), ah(k)
+ end do
+
+ write(0,*) 'EARTH RADIUS = ', grid % sphere_radius
+
+! MGD 2-0-0, not used in 2-0-1
+ if (trim(config_dcmip_case) == '2-0-0') then
+ ! for hx computation
+ r1m = .75*pii
+ r2m = pii/16.
+ end if
+
+! MGD 2-0-1, not used in 2-0-0
+ if (trim(config_dcmip_case) == '2-0-1') then
+! setting for terrain
+! xa = pii/16. ! for specifying mtn with in degrees
+ xa = pii*grid%sphere_radius/16. ! corresponds to ~11 grid intervals across entire mtn with 2 deg res
+ end if
+
+
+! MGD both 2-0-0 and 2-0-1
+ hm = 2000.0
+
+ do iCell=1,grid % nCells
+
+
+ if (trim(config_dcmip_case) == '2-0-0') then
+! Comb mountain as specified for DCMIP case 2.0
+! MGD BEGIN 2-0-0
+ xi = grid % lonCell % array(iCell)
+ yi = grid % latCell % array(iCell)
+
+ rad = acos(cos(xi)*cos(yi))
+
+ if (rad.lt.r1m) THEN
+ hx(1,iCell) = hm*cos(.5*pii*rad/r1m)**2.*cos(pii*rad/r2m)**2
+ else
+ hx(1,iCell) = 0.
+ end if
+! MGD END 2-0-0
+ end if
+
+ if (trim(config_dcmip_case) == '2-0-1') then
+! cosine**2 ridge
+! MGD BEGIN 2-0-1
+
+ xi = grid % lonCell % array(iCell)
+ yi = grid % latCell % array(iCell)
+ xc = sphere_distance(yi, xi, yi, 0., grid % sphere_radius)
+ yc = sphere_distance(yi, xi, 0., xi, grid % sphere_radius)
+
+ if (abs(xc).ge.xa) then ! for mtn ridge with uniform width in km
+! if (abs(xi).ge.xa.and.abs(2.*pii-xi).ge.xa) then ! for mtn ridge with uniform width in degrees
+ hx(1,iCell) = 0.
+ else
+! for mtn ridge with uniform width in km
+ hx(1,iCell) = hm*cos(.5*pii*xc/xa)**2*cos(yc/grid % sphere_radius)
+! for mtn ridge with uniform width in degrees
+! hx(1,iCell) = hm*cos(.5*pii*xi/xa)**2*cos(yc/grid % sphere_radius)
+ end if
+! MGD END 2-0-1
+ end if
+
+ hx(:,iCell) = hx(1,iCell)
+
+ hx(nz,iCell) = zt
+
+ end do
+
+ hmax = maxval(hx(1,:))
+ write(6,*) "max terrain height = ",hmax
+
+ if (config_smooth_surfaces) then
+
+ write(0,*) ' '
+ write(0,*) ' Smoothing vertical coordinate surfaces'
+ write(0,*) ' '
+
+ allocate(hs (grid % nCells+1))
+ allocate(hs1(grid % nCells+1))
+
+ dzmin = 0.5
+ sm0 = 0.5
+ nsm = 30
+
+ write(6,*) 'dzmin = ',dzmin,' sm0 = ',sm0,' nsm = ',nsm
+
+ do k=2,kz-1
+ hx(k,:) = hx(k-1,:)
+ dzminf = zw(k)-zw(k-1)
+
+! dzmin = max(0.5_RKIND,1.-.5*zw(k)/hm)
+
+ sm = sm0*max( min(.5*zw(k)/hm,1.0_RKIND), .05 )
+
+ do i=1,nsm
+ do iCell=1,grid % nCells
+ hs1(iCell) = 0.
+ do j = 1,nEdgesOnCell(iCell)
+
+ hs1(iCell) = hs1(iCell) + dvEdge(edgesOnCell(j,iCell)) &
+ / dcEdge(edgesOnCell(j,iCell)) &
+ * (hx(k,cellsOnCell(j,iCell))-hx(k,iCell))
+ end do
+ hs1(iCell) = hx(k,iCell) + sm*hs1(iCell)
+
+ hs(iCell) = 0.
+ ! do j = 1,nEdgesOnCell(iCell)
+ ! hs(iCell) = hs(iCell) + dvEdge(edgesOnCell(j,iCell)) &
+ ! / dcEdge(edgesOnCell(j,iCell)) &
+ ! * (hs1(cellsOnCell(j,iCell))-hs1(iCell))
+ ! end do
+ hs(iCell) = hs1(iCell) - 0.*hs(iCell)
+
+ end do
+
+ tempField => tempFieldTarget
+ tempField % block => block
+ tempField % dimSizes(1) = grid % nCells
+ tempField % sendList => parinfo % cellsToSend
+ tempField % recvList => parinfo % cellsToRecv
+ tempField % copyList => parinfo % cellsToCopy
+ tempField % array => hs
+ tempField % prev => null()
+ tempField % next => null()
+
+ call mpas_dmpar_exch_halo_field(tempField)
+
+ ! dzmina = minval(hs(:)-hx(k-1,:))
+ dzmina = minval(zw(k)+ah(k)*hs(1:grid%nCellsSolve)-zw(k-1)-ah(k-1)*hx(k-1,1:grid%nCellsSolve))
+ call mpas_dmpar_min_real(dminfo, dzmina, dzmina_global)
+ ! write(0,*) ' k,i, dzmina, dzmin, zw(k)-zw(k-1) ', k,i, dzmina, dzmin, zw(k)-zw(k-1)
+ if (dzmina_global >= dzmin*(zw(k)-zw(k-1))) then
+ hx(k,:)=hs(:)
+ dzminf = dzmina_global
+ else
+ exit
+ end if
+ end do
+ write(0,*) k,i,sm,dzminf/(zw(k)-zw(k-1)),dzmina/(zw(k)-zw(k-1))
+ end do
+
+ do k=kz,nz
+ hx(k,:) = 0.
+ end do
+
+ deallocate(hs )
+ deallocate(hs1)
+
+ else
+
+ do k=2,nz1
+ dzmina = minval(zw(k)+ah(k)*hx(k,:)-zw(k-1)-ah(k-1)*hx(k-1,:))
+ write(0,*) k,dzmina/(zw(k)-zw(k-1))
+ end do
+
+ end if
+
+
+ do iCell=1,grid % nCells
+ do k=1,nz
+ zgrid(k,iCell) = zw(k) + ah(k)*hx(k,iCell)
+ end do
+ do k=1,nz1
+ zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
+ end do
+ end do
+
+ do i=1, grid % nEdges
+ iCell1 = grid % CellsOnEdge % array(1,i)
+ iCell2 = grid % CellsOnEdge % array(2,i)
+ do k=1,nz
+ zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
+ end do
+ end do
+ do i=1, grid % nCells
+ do k=1,nz1
+ ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
+ dss(k,i) = 0.
+ ztemp = zgrid(k,i)
+ if(ztemp.gt.zd+.1) then
+ dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
+ end if
+ end do
+ enddo
+
+ write(0,*) ' grid metrics setup complete '
+
+ do k=1,nz1
+ dzw (k) = zw(k+1)-zw(k)
+ rdzw(k) = 1./dzw(k)
+ zu(k ) = .5*(zw(k)+zw(k+1))
+ end do
+ do k=2,nz1
+ dzu (k) = .5*(dzw(k)+dzw(k-1))
+ rdzu(k) = 1./dzu(k)
+ fzp (k) = .5* dzw(k )/dzu(k)
+ fzm (k) = .5* dzw(k-1)/dzu(k)
+ rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
+ rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
+ end do
+
+! d1 = .5*dzw(1)
+! d2 = dzw(1)+.5*dzw(2)
+! d3 = dzw(1)+dzw(2)+.5*dzw(3)
+! cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+
+ cof1 = (2.*dzu(2)+dzu(3))/(dzu(2)+dzu(3))*dzw(1)/dzu(2)
+ cof2 = dzu(2) /(dzu(2)+dzu(3))*dzw(1)/dzu(3)
+ cf1 = fzp(2) + cof1
+ cf2 = fzm(2) - cof1 - cof2
+ cf3 = cof2
+
+ grid % cf1 % scalar = cf1
+ grid % cf2 % scalar = cf2
+ grid % cf3 % scalar = cf3
+
+ um = 0.
+ gamma = .0065 ! temp lapse rate in K/km
+
+! MGD BEGIN 2-0-0
+ if (trim(config_dcmip_case) == '2-0-0') then
+ zinb = zt ! no inversion layer
+ zint = zt ! no inversion layer
+ end if
+! MGD END 2-0-0
+! MGD BEGIN 2-0-1
+ if (trim(config_dcmip_case) == '2-0-1') then
+ zinb = 3000. ! bottom of inversion layer
+ zint = 5000. ! top of inversion layer
+ end if
+! MGD END 2-0-1
+
+ ! computing intermediate T and Theta used to build sounding that includes inversion layer
+ tinv = t0-gamma*zinb
+ th_inb = t0*(1.-gamma*zinb/t0)**(1.-gravity/(cp*gamma))
+ th_int = th_inb*exp((gravity*(zint-zinb))/(cp*tinv))
+ write(6,*) ' zinb = ',zinb,' zint = ',zint,' tinv = ',tinv,'th_inb = ',th_inb,' th_int = ',th_int
+
+ do i=1,grid % nCells
+
+ pis = 1.
+
+ do k=1,nz1
+ ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
+
+! Isothermal reference sounding
+
+ tb(k,i) = t0*exp(gravity*ztemp/(cp*t0))
+
+! Low level inversion initial sounding
+
+ if(ztemp.le.zinb) then
+ t (k,i) = t0*(1.-gamma*ztemp/t0)**(1.-gravity/(cp*gamma))
+ else if(ztemp.le.zint) then
+ t (k,i) = th_inb*exp((gravity*(ztemp-zinb))/(cp*tinv))
+ else
+ t (k,i) = th_int*(1.-gamma*(ztemp-zint)/tinv)**(1.-gravity/(cp*gamma))
+ end if
+
+ rh(k,i) = 0.
+ end do
+ end do
+
+ !
+ ! Initialize wind field
+ !
+ do iEdge=1,grid % nEdges
+ do k=1,nz1
+ u(k,iEdge) = um
+ end do
+ end do
+
+ do k=1,nz1
+ grid % u_init % array(k) = um
+ end do
+
+!
+! reference sounding based on dry atmosphere
+!
+ do i=1, grid % nCells
+
+ pis = 1.
+
+ pitop(i) = pis-.5*dzw(1)*gravity/(cp*tb(1,1)*zz(1,1))
+ do k=2,nz1
+ pitop(i) = pitop(i)-dzu(k)*gravity/(cp*(fzm(k)*tb(k,1)+fzp(k)*tb(k-1,1)) &
+ *(fzm(k)*zz(k,1)+fzp(k)*zz(k-1,1)))
+ end do
+ pitop(i) = pitop(i)-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1))
+ ptopb(i) = p0*pitop(i)**(1./rcp)
+
+ pb(nz1,i) = pitop(i)+.5*dzw(nz1)*gravity/(cp*tb(nz1,i)*zz(nz1,i))
+ p (nz1,i) = pitop(i)+.5*dzw(nz1)*gravity/(cp*t (nz1,i)*zz(nz1,i))
+ do k=nz1-1,1,-1
+ pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*.5*(tb(k,i)+tb(k+1,i)) &
+ *.5*(zz(k,i)+zz(k+1,i)))
+ p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*.5*(t (k,i)+t (k+1,i)) &
+ *.5*(zz(k,i)+zz(k+1,i)))
+ end do
+ do k=1,nz1
+ rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
+ rtb(k,i) = rb(k,i)*tb(k,i)
+ rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
+ cqw(k,i) = 1.
+ end do
+ end do
+
+ write(0,*) ' ***** base state sounding ***** '
+ write(0,*) 'k pb p rb rtb rr tb t'
+ do k=1,grid%nVertLevels
+ write(0,'(i2,7(2x,f14.9))') k,pb(k,1),p(k,1),rb(k,1),rtb(k,1),rr(k,1),tb(k,1),t(k,1)
+ end do
+
+ scalars(index_qv,:,:) = 0.
+!!!
+!-------------------------------------------------------------------
+! ITERATIONS TO CONVERGE MOIST SOUNDING
+ do itr=1,30
+
+ do i = 1, grid % nCells
+
+ pis = 1.
+
+ pitop(i) = pis-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
+
+ do k=2,nz1
+ pitop(i) = pitop(i)-dzu(k)*gravity/(cp*cqw(k,1)*(fzm(k)*t (k,1)+fzp(k)*t (k-1,1)) &
+ *(fzm(k)*zz(k,1)+fzp(k)*zz(k-1,1)))
+ end do
+ pitop(i) = pitop(i) - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
+ ptop = p0*pitop(i)**(1./rcp)
+
+ pp(nz1,i) = ptop-ptopb(i)+.5*dzw(nz1)*gravity* &
+ (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
+ do k=nz1-1,1,-1
+ pp(k,i) = pp(k+1,i)+dzu(k+1)*gravity* &
+ (fzm(k)*(rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i)) &
+ +fzp(k)*(rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i)))
+ end do
+ do k=1,nz1
+ rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
+ -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
+ p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
+ rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
+ end do
+!
+! update water vapor mixing ratio from humitidty profile
+!
+ do k=1,nz1
+ temp = p(k,i)*t(k,i)
+ pres = p0*p(k,i)**(1./rcp)
+ qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
+ scalars(index_qv,k,i) = min(0.014_RKIND,rh(k,i)*qvs)
+ end do
+
+ do k=1,nz1
+ t (k,i) = t(k,i)*(1.+1.61*scalars(index_qv,k,i))
+ end do
+ do k=2,nz1
+ cqw(k,i) = 1./(1.+.5*( scalars(index_qv,k-1,i) &
+ +scalars(index_qv,k ,i)))
+ end do
+
+ end do ! loop over cells
+
+ end do ! iteration loop
+!----------------------------------------------------------------------
+!
+ write(0,*) ' *** sounding for the simulation ***'
+ write(0,*) ' z temp theta pres rho_m u rr'
+ do k=1,nz1
+ write(0,'(8(f14.9,2x))') .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
+ t(k,1)/(1.+1.61*scalars(index_qv,k,1))*p(k,1), &
+ t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
+ .01*p0*p(k,1)**(1./rcp), &
+! 1000.*scalars(index_qv,k,1), &
+ (rb(k,1)+rr(k,1))*(1.+scalars(index_qv,k,1)), &
+ grid % u_init % array(k), rr(k,1)
+ end do
+
+ do i=1,grid % ncells
+ do k=1,nz1
+ rho_zz(k,i) = rb(k,i)+rr(k,i)
+ end do
+
+ do k=1,nz1
+ grid % t_init % array(k,i) = t(k,i)
+ end do
+ end do
+
+ do i=1,grid % nEdges
+ cell1 = grid % CellsOnEdge % array(1,i)
+ cell2 = grid % CellsOnEdge % array(2,i)
+ if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
+ do k=1,nz1
+ ru (k,i) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*u(k,i)
+ end do
+ end if
+ end do
+
+!
+! pre-calculation z-metric terms in omega eqn.
+!
+ do iEdge = 1,grid % nEdges
+ cell1 = CellsOnEdge(1,iEdge)
+ cell2 = CellsOnEdge(2,iEdge)
+ if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
+
+ do k = 1, grid%nVertLevels
+
+ if (config_theta_adv_order == 2) then
+!! test for metric consistency - forces 2nd order metrics with 4th order advection
+! if (config_theta_adv_order == 4) then
+
+ z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2.
+
+ else !theta_adv_order == 3 or 4
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ if ( grid % CellsOnCell % array (i,cell1) > 0) &
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ if ( grid % CellsOnCell % array (i,cell2) > 0) &
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
+ - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+
+ if (config_theta_adv_order == 3) then
+ z_edge3 = - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ else
+ z_edge3 = 0.
+ end if
+
+ end if
+
+ zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/AreaCell(cell1)
+ zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/AreaCell(cell2)
+ zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
+ zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
+
+! if (k /= 1) then
+! zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb(k,1,iEdge)
+! zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb(k,2,iEdge)
+! zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb3(k,1,iEdge)
+! zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb3(k,2,iEdge)
+! end if
+
+ end do
+
+ end if
+ end do
+
+! for including terrain
+ state % w % array(:,:) = 0.0
+ diag % rw % array(:,:) = 0.0
+
+!
+! calculation of omega, rw = zx * ru + zz * rw
+!
+
+! do iEdge = 1,grid % nEdges
+
+! cell1 = CellsOnEdge(1,iEdge)
+! cell2 = CellsOnEdge(2,iEdge)
+
+! if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
+! do k = 2, grid%nVertLevels
+! flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge))
+! diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
+! diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+
+! if (config_theta_adv_order ==3) then
+! diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
+! - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+! diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
+! + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+! end if
+
+! end do
+! end if
+
+! end do
+
+ ! Compute w from rho_zz and rw
+ do iCell=1,grid%nCells
+ do k=2,grid%nVertLevels
+ state % w % array(k,iCell) = diag % rw % array(k,iCell) &
+ / (fzp(k) * state % rho_zz % array(k-1,iCell) + fzm(k) * state % rho_zz % array(k,iCell))
+ end do
+ end do
+
+
+ do iEdge=1,grid % nEdges
+ grid % fEdge % array(iEdge) = 0.
+ end do
+
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 0.
+ end do
+
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ diag % v % array(:,:) = 0.0
+ do iEdge = 1, grid%nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ if (eoe > 0) then
+ do k = 1, grid%nVertLevels
+ diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
+ end do
+ end if
+ end do
+ end do
+
+! do k=1,grid%nVertLevels
+! write(0,*) ' k,u_init, t_init, qv_init ',k,grid % u_init % array(k),grid % t_init% array(k),grid % qv_init % array(k)
+! end do
+
+ ! Compute rho and theta from rho_zz and theta_m
+ do iCell=1,grid%nCells
+ do k=1,grid%nVertLevels
+ diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell))
+ end do
+ end do
+
+ end subroutine init_atm_test_case_resting_atmosphere
+
+
integer function nearest_cell(target_lat, target_lon, &
start_cell, &
nCells, maxEdges, nEdgesOnCell, cellsOnCell, latCell, lonCell)
@@ -4573,10 +6229,12 @@
nearest_distance = current_distance
do i = 1, nEdgesOnCell(current_cell)
iCell = cellsOnCell(i,current_cell)
- d = sphere_distance(latCell(iCell), lonCell(iCell), target_lat, target_lon, 1.0_RKIND)
- if (d < nearest_distance) then
- nearest_cell = iCell
- nearest_distance = d
+ if (iCell <= nCells) then
+ d = sphere_distance(latCell(iCell), lonCell(iCell), target_lat, target_lon, 1.0_RKIND)
+ if (d < nearest_distance) then
+ nearest_cell = iCell
+ nearest_distance = d
+ end if
end if
end do
end do
@@ -4625,10 +6283,12 @@
end if
do i = 1, nEdgesOnCell(iCell)
iEdge = edgesOnCell(i,iCell)
- d = sphere_distance(latEdge(iEdge), lonEdge(iEdge), target_lat, target_lon, 1.0_RKIND)
- if (d < nearest_distance) then
- nearest_edge = iEdge
- nearest_distance = d
+ if (iEdge <= nEdges) then
+ d = sphere_distance(latEdge(iEdge), lonEdge(iEdge), target_lat, target_lon, 1.0_RKIND)
+ if (d < nearest_distance) then
+ nearest_edge = iEdge
+ nearest_distance = d
+ end if
end if
end do
end do
Modified: branches/ocean_projects/shared_advection/src/core_nhyd_atmos/Makefile
===================================================================
--- branches/ocean_projects/shared_advection/src/core_nhyd_atmos/Makefile 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_nhyd_atmos/Makefile 2013-03-08 17:10:33 UTC (rev 2572)
@@ -4,7 +4,6 @@
#PHYSICS=
OBJS = mpas_atm_mpas_core.o \
- mpas_atm_test_cases.o \
mpas_atm_time_integration.o \
mpas_atm_advection.o
@@ -19,13 +18,11 @@
core_hyd: $(OBJS)
ar -ru libdycore.a $(OBJS) phys/*.o
-mpas_atm_test_cases.o: mpas_atm_advection.o
-
mpas_atm_time_integration.o:
mpas_atm_advection.o:
-mpas_atm_mpas_core.o: mpas_atm_advection.o mpas_atm_test_cases.o mpas_atm_time_integration.o
+mpas_atm_mpas_core.o: mpas_atm_advection.o mpas_atm_time_integration.o
clean:
( cd ../core_atmos_physics; make clean )
Modified: branches/ocean_projects/shared_advection/src/core_nhyd_atmos/Registry
===================================================================
--- branches/ocean_projects/shared_advection/src/core_nhyd_atmos/Registry 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_nhyd_atmos/Registry 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,7 +1,6 @@
%
% namelist type namelist_record name default_value
%
-namelist integer nhyd_model config_test_case 0
namelist character nhyd_model config_time_integration SRK3
namelist real nhyd_model config_dt 600.0
namelist character nhyd_model config_calendar_type gregorian
@@ -38,7 +37,6 @@
namelist integer nhyd_model config_num_halos 2
namelist real damping config_zd 22000.0
namelist real damping config_xnutr 0.0
-namelist integer dimensions config_nvertlevels 26
namelist character io config_input_name init.nc
namelist character io config_sfc_update_name sfc_update.nc
namelist character io config_output_name output.nc
@@ -69,7 +67,7 @@
dim FIFTEEN 15
dim TWENTYONE 21
dim R3 3
-dim nVertLevels namelist:config_nvertlevels
+dim nVertLevels nVertLevels
dim nVertLevelsP1 nVertLevels+1
%
@@ -115,7 +113,7 @@
var persistent real edgeNormalVectors ( R3 nEdges ) 0 iro edgeNormalVectors mesh - -
var persistent real localVerticalUnitVectors ( R3 nCells ) 0 iro localVerticalUnitVectors mesh - -
-var persistent real cellTangentPlane ( R3 TWO nEdges ) 0 iro cellTangentPlane mesh - -
+var persistent real cellTangentPlane ( R3 TWO nCells ) 0 iro cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
Modified: branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_advection.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_advection.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_advection.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -111,9 +111,9 @@
do i=1,n
advCells(i+1,iCell) = cell_list(i)
- xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
- yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
- zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
+ xc(i) = grid % xCell % array(advCells(i+1,iCell))/grid%sphere_radius
+ yc(i) = grid % yCell % array(advCells(i+1,iCell))/grid%sphere_radius
+ zc(i) = grid % zCell % array(advCells(i+1,iCell))/grid%sphere_radius
end do
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
@@ -131,8 +131,8 @@
xc(i+1), yc(i+1), zc(i+1), &
xc(ip2), yc(ip2), zc(ip2) )
- dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1) )
+ dl_sphere(i) = grid%sphere_radius*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
end do
length_scale = 1.
@@ -262,12 +262,12 @@
if (ip1 > n-1) ip1 = 1
iEdge = grid % EdgesOnCell % array (i,iCell)
- xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/grid%sphere_radius
+ yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/grid%sphere_radius
+ zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/grid%sphere_radius
+ xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/grid%sphere_radius
+ yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/grid%sphere_radius
+ zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/grid%sphere_radius
if ( grid % on_a_sphere ) then
call arc_bisect( xv1, yv1, zv1, &
@@ -825,16 +825,16 @@
! compute poynomial fit for this cell if all needed neighbors exist
if (grid % on_a_sphere) then
- xc(1) = grid % xCell % array(iCell)/a
- yc(1) = grid % yCell % array(iCell)/a
- zc(1) = grid % zCell % array(iCell)/a
+ xc(1) = grid % xCell % array(iCell)/grid%sphere_radius
+ yc(1) = grid % yCell % array(iCell)/grid%sphere_radius
+ zc(1) = grid % zCell % array(iCell)/grid%sphere_radius
do i=2,n
iv = grid % verticesOnCell % array(i-1,iCell)
- xc(i) = grid % xVertex % array(iv)/a
- yc(i) = grid % yVertex % array(iv)/a
- zc(i) = grid % zVertex % array(iv)/a
+ xc(i) = grid % xVertex % array(iv)/grid%sphere_radius
+ yc(i) = grid % yVertex % array(iv)/grid%sphere_radius
+ zc(i) = grid % zVertex % array(iv)/grid%sphere_radius
end do
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
@@ -852,8 +852,8 @@
xc(i+1), yc(i+1), zc(i+1), &
xc(ip2), yc(ip2), zc(ip2) )
- dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1) )
+ dl_sphere(i) = grid%sphere_radius*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
end do
length_scale = 1.
Modified: branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_mpas_core.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -20,7 +20,6 @@
use mpas_configure
use mpas_kind_types
use mpas_grid_types
- use atm_test_cases
implicit none
@@ -37,8 +36,21 @@
integer :: i
integer :: ierr
- if (.not. config_do_restart) call atm_setup_test_case(domain)
+ if (.not. config_do_restart) then
+ ! Code that was previously handled by atm_setup_test_case()
+
+ block => domain % blocklist
+ do while (associated(block))
+ do i=2,nTimeLevs
+ call mpas_copy_state(block % state % time_levs(i) % state, block % state % time_levs(1) % state)
+ end do
+ block => block % next
+ end do
+
+ end if
+
+
!
! Initialize core
!
Deleted: branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_test_cases.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_test_cases.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_test_cases.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,2184 +0,0 @@
-module atm_test_cases
-
- use mpas_grid_types
- use mpas_configure
- use mpas_constants
- use mpas_dmpar
- use atm_advection
-#ifdef DO_PHYSICS
- use mpas_atmphys_control
-#endif
-
-
- contains
-
-
- subroutine atm_setup_test_case(domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Configure grid metadata and model state for the hydrostatic test case
- ! specified in the namelist
- !
- ! Output: block - a subset (not necessarily proper) of the model domain to be
- ! initialized
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- integer :: i
- type (block_type), pointer :: block_ptr
-
- if (config_test_case == 0) then
- write(0,*) ' Using initial conditions from input file'
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
- block_ptr => block_ptr % next
- end do
-
- else if ((config_test_case == 1) .or. (config_test_case == 2) .or. (config_test_case == 3)) then
- write(0,*) ' Jablonowski and Williamson baroclinic wave test case '
- if (config_test_case == 1) write(0,*) ' no initial perturbation '
- if (config_test_case == 2) write(0,*) ' initial perturbation included '
- if (config_test_case == 3) write(0,*) ' normal-mode perturbation included '
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- write(0,*) ' calling test case setup '
- call atm_test_case_jw(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, &
- block_ptr % diag_physics ,config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if ((config_test_case == 4) .or. (config_test_case ==5)) then
-
- write(0,*) ' squall line - super cell test case '
- if (config_test_case == 4) write(0,*) ' squall line test case'
- if (config_test_case == 5) write(0,*) ' supercell test case'
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- write(0,*) ' calling test case setup '
- call atm_test_case_squall_line(domain % dminfo, block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 6 ) then
-
- write(0,*) ' mountain wave test case '
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- write(0,*) ' calling test case setup '
- call atm_test_case_mtn_wave(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else
-
-
- write(0,*) ' Only test case 1, 2, 3, 4, 5 and 6 are currently supported for nonhydrostatic core '
- stop
- end if
-
-
-#ifdef DO_PHYSICS
- !initialization of surface input variables technically not needed to run our current set of
- !idealized test cases:
- if (config_test_case > 0) then
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call physics_idealized_init(block_ptr % mesh, block_ptr % sfc_input)
- block_ptr => block_ptr % next
- end do
-
- endif
-#endif
-
- end subroutine atm_setup_test_case
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine atm_test_case_jw(grid, state, diag, diag_physics, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
- type (diag_type), intent(inout) :: diag
- type (diag_physics_type), intent(inout) :: diag_physics
- integer, intent(in) :: test_case
-
- real (kind=RKIND), parameter :: u0 = 35.0
- real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
- real (kind=RKIND), parameter :: omega_e = 7.29212e-05
- real (kind=RKIND), parameter :: t0b = 250., t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
- real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
- real (kind=RKIND), parameter :: theta_c = pii/4.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
-
- real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:), pointer :: surface_pressure
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
- real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt
- real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
-
-!.. initialization of moisture:
- integer:: index_qv
- real (kind=RKIND),parameter :: rh_max = 0.40 ! Maximum relative humidity
-! real (kind=RKIND),parameter :: rh_max = 0.70 ! Maximum relative humidity
- real (kind=RKIND),dimension(:,:), pointer:: qsat, relhum
- real (kind=RKIND),dimension(:,:,:),pointer:: scalars
-!.. end initialization of moisture.
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge
- real (kind=RKIND), dimension(:), pointer :: dvEdge, AreaCell
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
-
- 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
- real (kind=RKIND) :: lon_Edge
-
- real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
-
- real (kind=RKIND) :: es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znuc, znuv, bn, divh, dpn
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: sh, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt, temperature_1d
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2, psurf
-
- ! storage for (lat,z) arrays for zonal velocity calculation
-
- logical, parameter :: rebalance = .true.
- integer, parameter :: nlat=721
- real (kind=RKIND), dimension(grid % nVertLevels) :: flux_zonal
- real (kind=RKIND), dimension(grid % nVertLevels + 1, nlat) :: zgrid_2d
- real (kind=RKIND), dimension(grid % nVertLevels, nlat) :: u_2d, pp_2d, rho_2d, qv_2d, etavs_2d, zz_2d
- real (kind=RKIND), dimension(grid % nVertLevels, nlat-1) :: zx_2d
- real (kind=RKIND), dimension(nlat) :: lat_2d
- real (kind=RKIND) :: dlat, hx_1d
- real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2
-
- logical, parameter :: moisture = .true.
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- 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
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- dvEdge => grid % dvEdge % array
- AreaCell => grid % AreaCell % array
- CellsOnEdge => grid % CellsOnEdge % array
-
- deriv_two => grid % deriv_two % array
- zb => grid % zb % array
- zb3 => grid % zb3% array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
- nCellsSolve = grid % nCellsSolve
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- pb => diag % exner_base % array
- rb => diag % rho_base % array
- tb => diag % theta_base % array
- rtb => diag % rtheta_base % array
- p => diag % exner % array
-
- ppb => diag % pressure_base % array
- pp => diag % pressure_p % array
-
- rho_zz => state % rho_zz % array
- rr => diag % rho_p % array
- t => state % theta_m % array
- rt => diag % rtheta_p % array
-
- surface_pressure => diag % surface_pressure % array
-
-!.. initialization of moisture:
- scalars => state % scalars % array
- qsat => diag_physics % qsat % array
- relhum => diag_physics % relhum % array
- scalars(:,:,:) = 0.0
- qsat(:,:) = 0.0
- relhum(:,:) = 0.0
- qv_2d(:,:) = 0.0
-!.. end initialization of moisture.
-
- surface_pressure(:) = 0.0
-
- call atm_initialize_advection_rk(grid)
- call atm_initialize_deformation_weights(grid)
-
- index_qv = state % index_qv
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- phi = grid % latCell % array (iCell)
- hx(k,iCell) = u0/gravity*cos(etavs)**1.5 &
- *((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(etavs)**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
- enddo
- enddo
-
- ! Metrics for hybrid coordinate and vertical stretching
-
- str = 1.8
- zt = 45000.
- dz = zt/float(nz1)
-
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-
-! sh(k) is the stretching specified for height surfaces
-
- sh(k) = (real(k-1)*dz/zt)**str
-
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k) and define sh(k) = zc(k)/zt
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
- zw(k) = float(k-1)*dz
-! zw(k) = sh(k)*zt
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
- ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
-! ah(k) = 0.
- write(0,*) ' k, sh, zw, ah ',k,sh(k),zw(k),ah(k)
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2)
- COF2 = DZU(2) /(DZU(2)+DZU(3))*DZW(1)/DZU(3)
- CF1 = FZP(2) + COF1
- CF2 = FZM(2) - COF1 - COF2
- CF3 = COF2
-
-! d1 = .5*dzw(1)
-! d2 = dzw(1)+.5*dzw(2)
-! d3 = dzw(1)+dzw(2)+.5*dzw(3)
-! cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-! cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- write(0,*) ' cf1, cf2, cf3 = ',cf1,cf2,cf3
-
- grid % cf1 % scalar = cf1
- grid % cf2 % scalar = cf2
- grid % cf3 % scalar = cf3
-
- do iCell=1,grid % nCells
- do k=1,nz
- zgrid(k,iCell) = (1.-ah(k))*(sh(k)*(zt-hx(k,iCell))+hx(k,iCell)) &
- + ah(k) * sh(k)* zt
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- !do k=1,nz1
- ! write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- !enddo
-
- !do k=1,nz1
- ! write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- !enddo
-
- write(0,*) ' grid metrics setup complete '
-
-!************** section for 2d (z,lat) calc for zonal velocity
-
- dlat = 0.5*pii/float(nlat-1)
- do i = 1,nlat
-
- lat_2d(i) = float(i-1)*dlat
- phi = lat_2d(i)
- hx_1d = u0/gravity*cos(etavs)**1.5 &
- *((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(etavs)**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
-
- do k=1,nz
- zgrid_2d(k,i) = (1.-ah(k))*(sh(k)*(zt-hx_1d)+hx_1d) &
- + ah(k) * sh(k)* zt
- end do
- do k=1,nz1
- zz_2d (k,i) = (zw(k+1)-zw(k))/(zgrid_2d(k+1,i)-zgrid_2d(k,i))
- end do
-
- do k=1,nz1
- ztemp = .5*(zgrid_2d(k+1,i)+zgrid_2d(k,i))
- ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
- pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
- rb (k,i) = ppb(k,i)/(rgas*t0b*zz_2d(k,i))
- tb (k,i) = t0b/pb(k,i)
- rtb(k,i) = rb(k,i)*tb(k,i)
- p (k,i) = pb(k,i)
- pp (k,i) = 0.
- rr (k,i) = 0.
- end do
-
-
- do itr = 1,10
-
- do k=1,nz1
- eta (k) = (ppb(k,i)+pp(k,i))/p0
- etav(k) = (eta(k)-.252)*pii/2.
- if(eta(k).ge.znut) then
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
- end if
- end do
-
- phi = lat_2d (i)
- do k=1,nz1
- temperature_1d(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
- *sqrt(cos(etav(k)))* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *2.*u0*cos(etav(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)/(1.+0.61*qv_2d(k,i))
-
-
- ztemp = .5*(zgrid_2d(k,i)+zgrid_2d(k+1,i))
- ptemp = ppb(k,i) + pp(k,i)
-
- !get moisture
- if (moisture) then
- qv_2d(k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max )
- end if
-
- tt(k) = temperature_1d(k)*(1.+1.61*qv_2d(k,i))
- end do
-
- do itrp = 1,25
- do k=1,nz1
- rr(k,i) = (pp(k,i)/(rgas*zz_2d(k,i)) - rb(k,i)*(tt(k)-t0b))/tt(k)
- end do
-
- ppi(1) = p0-.5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv_2d(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv_2d(2,i)))
-
- ppi(1) = ppi(1)-ppb(1,i)
- do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv_2d(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv_2d(k+1,i))
- end do
-
- do k=1,nz1
- pp(k,i) = .2*ppi(k)+.8*pp(k,i)
- end do
-
- end do ! end inner iteration loop itrp
-
- end do ! end outer iteration loop itr
-
- do k=1,nz1
- rho_2d(k,i) = rr(k,i)+rb(k,i)
- pp_2d(k,i) = pp(k,i)
- etavs_2d(k,i) = ((ppb(k,i)+pp(k,i))/p0 - 0.252)*pii/2.
- u_2d(k,i) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(k,i))**1.5)
- end do
-
- end do ! end loop over latitudes for 2D zonal wind field calc
-
- !SHP-balance:: in case of rebalacing for geostrophic wind component
- if (rebalance) then
-
- do i=1,nlat-1
- do k=1,nz1
- zx_2d(k,i) = (zgrid_2d(k,i+1)-zgrid_2d(k,i))/(dlat*r_earth)
- end do
- end do
-
- call atm_recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz_2d,zx_2d, &
- cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat)
-
- end if
-
-!******************************************************************
-
-!
-!---- baroclinc wave initialization ---------------------------------
-!
-! reference sounding based on dry isothermal atmosphere
-!
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
- pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
- rb (k,i) = ppb(k,i)/(rgas*t0b*zz(k,i))
- tb (k,i) = t0b/pb(k,i)
- rtb(k,i) = rb(k,i)*tb(k,i)
- p (k,i) = pb(k,i)
- pp (k,i) = 0.
- rr (k,i) = 0.
- end do
-
-! if(i == 1) then
-! do k=1,nz1
-! write(0,*) ' k, ppb, pb, rb, tb (k,1) ',k,ppb(k,1),pb(k,1),rb(k,1)*zz(k,1),tb(k,1)
-! enddo
-! end if
-
- 200 format(4i6,8(1x,e15.8))
- 201 format(3i6,8(1x,e15.8))
- 202 format(2i6,10(1x,e15.8))
- 203 format(i6,10(1x,e15.8))
-
-! iterations to converge temperature as a function of pressure
-!
- do itr = 1,10
-
- do k=1,nz1
- eta (k) = (ppb(k,i)+pp(k,i))/p0
- etav(k) = (eta(k)-.252)*pii/2.
- if(eta(k).ge.znut) then
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
- end if
- end do
- phi = grid % latCell % array (i)
- do k=1,nz1
- temperature_1d(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
- *sqrt(cos(etav(k)))* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *2.*u0*cos(etav(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)/(1.+0.61*scalars(index_qv,k,i))
-
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- ptemp = ppb(k,i) + pp(k,i)
-
- !get moisture
- if (moisture) then
-
- !scalars(index_qv,k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max )
-
- if(ptemp < 50000.) then
- relhum(k,i) = 0.0
- elseif(ptemp > p0) then
- relhum(k,i) = 1.0
- else
- relhum(k,i) = (1.-((p0-ptemp)/50000.)**1.25)
- endif
- relhum(k,i) = min(rh_max,relhum(k,i))
-
- !.. calculation of water vapor mixing ratio:
- if (temperature_1d(k) > 273.15) then
- es = 1000.*0.6112*exp(17.67*(temperature_1d(k)-273.15)/(temperature_1d(k)-29.65))
- else
- es = 1000.*0.6112*exp(21.8745584*(temperature_1d(k)-273.15)/(temperature_1d(k)-7.66))
- end if
- qsat(k,i) = (287.04/461.6)*es/(ptemp-es)
- if(relhum(k,i) .eq. 0.0) qsat(k,i) = 0.0
- scalars(index_qv,k,i) = relhum(k,i)*qsat(k,i)
- end if
-
- tt(k) = temperature_1d(k)*(1.+1.61*scalars(index_qv,k,i))
-
- end do
-
- do itrp = 1,25
- do k=1,nz1
- rr(k,i) = (pp(k,i)/(rgas*zz(k,i)) - rb(k,i)*(tt(k)-t0b))/tt(k)
- end do
-
- ppi(1) = p0-.5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+scalars(index_qv,1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+scalars(index_qv,2,i)))
-
- ppi(1) = ppi(1)-ppb(1,i)
- do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
- end do
-
- do k=1,nz1
- pp(k,i) = .2*ppi(k)+.8*pp(k,i)
- end do
-
- end do ! end inner iteration loop itrp
-
- end do ! end outer iteration loop itr
-
- do k=1,nz1
- p (k,i) = ((ppb(k,i)+pp(k,i))/p0)**(rgas/cp)
- t (k,i) = tt(k)/p(k,i)
- rt (k,i) = t(k,i)*rr(k,i)+rb(k,i)*(t(k,i)-tb(k,i))
- rho_zz (k,i) = rb(k,i) + rr(k,i)
- end do
-
- !calculation of surface pressure:
- surface_pressure(i) = 0.5*dzw(1)*gravity &
- * (1.25*(rr(1,i) + rb(1,i)) * (1. + scalars(index_qv,1,i)) &
- - 0.25*(rr(2,i) + rb(2,i)) * (1. + scalars(index_qv,2,i)))
- surface_pressure(i) = surface_pressure(i) + pp(1,i) + ppb(1,i)
-
- end do ! end loop over cells
-
- !write(0,*)
- !write(0,*) '--- initialization of water vapor:'
- !do iCell = 1, grid % nCells
- ! if(iCell == 1 .or. iCell == grid % nCells) then
- ! do k = nz1, 1, -1
- ! write(0,202) iCell,k,t(k,iCell),relhum(k,iCell),qsat(k,iCell),scalars(index_qv,k,iCell)
- ! enddo
- ! write(0,*)
- ! endif
- !enddo
-
- lat_pert = latitude_pert*pii/180.
- lon_pert = longitude_pert*pii/180.
-
- do iEdge=1,grid % nEdges
-
- vtx1 = grid % VerticesOnEdge % array (1,iEdge)
- vtx2 = grid % VerticesOnEdge % array (2,iEdge)
- lat1 = grid%latVertex%array(vtx1)
- lat2 = grid%latVertex%array(vtx2)
- iCell1 = grid % cellsOnEdge % array(1,iEdge)
- iCell2 = grid % cellsOnEdge % array(2,iEdge)
- flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
-
- if (config_test_case == 2) then
- r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
- lat_pert, lon_pert, 1.0_RKIND)/(pert_radius)
- u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
-
- else if (config_test_case == 3) then
- lon_Edge = grid % lonEdge % array(iEdge)
- u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) &
- *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
- else
- u_pert = 0.0
- end if
-
- if (rebalance) then
-
- call atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,grid % dvEdge % array(iEdge),a,u0,nz1,nlat)
- do k=1,grid % nVertLevels
- fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2)))
- state % u % array(k,iEdge) = fluxk + u_pert
- end do
-
- else
-
- do k=1,grid % nVertLevels
- etavs = (0.5*(ppb(k,iCell1)+ppb(k,iCell2)+pp(k,iCell1)+pp(k,iCell2))/p0 - 0.252)*pii/2.
- fluxk = u0*flux*(cos(etavs)**1.5)
- state % u % array(k,iEdge) = fluxk + u_pert
- end do
-
- end if
-
- cell1 = grid % CellsOnEdge % array(1,iEdge)
- cell2 = grid % CellsOnEdge % array(2,iEdge)
- do k=1,nz1
- diag % ru % array (k,iEdge) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*state % u % array (k,iEdge)
- end do
-
- !
- ! Generate rotated Coriolis field
- !
-
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha_grid) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha_grid) &
- )
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha_grid) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha_grid) &
- )
- end do
-
- !
- ! CALCULATION OF OMEGA, RW = ZX * RU + ZZ * RW
- !
-
- !
- ! pre-calculation z-metric terms in omega eqn.
- !
- do iEdge = 1,grid % nEdges
- cell1 = CellsOnEdge(1,iEdge)
- cell2 = CellsOnEdge(2,iEdge)
-
- do k = 1, grid%nVertLevels
-
- if (config_theta_adv_order == 2) then
-
- z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2.
-
- else if (config_theta_adv_order == 3 .or. config_theta_adv_order ==4) then !theta_adv_order == 3 or 4
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
- - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
-
- if (config_theta_adv_order == 3) then
- z_edge3 = - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.
- else
- z_edge3 = 0.
- end if
-
- end if
-
- zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/AreaCell(cell1)
- zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/AreaCell(cell2)
- zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
- zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
-
- end do
-
- end do
-
- ! for including terrain
- diag % rw % array = 0.
- state % w % array = 0.
- do iEdge = 1,grid % nEdges
-
- cell1 = CellsOnEdge(1,iEdge)
- cell2 = CellsOnEdge(2,iEdge)
-
- do k = 2, grid%nVertLevels
- flux = (fzm(k)*diag % ru % array(k,iEdge)+fzp(k)*diag % ru % array(k-1,iEdge))
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)*flux
-
- if (config_theta_adv_order ==3) then
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
- - sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order* &
- (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
- + sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order* &
- (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)*flux
- end if
-
- end do
-
- end do
-
- ! Compute w from rho_zz and rw
- do iCell=1,grid%nCells
- do k=2,grid%nVertLevels
- state % w % array(k,iCell) = diag % rw % array(k,iCell) &
- / (fzp(k) * state % rho_zz % array(k-1,iCell) + fzm(k) * state % rho_zz % array(k,iCell))
- end do
- end do
-
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- diag % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- do k = 1, grid%nVertLevels
- diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end do
- end do
-
- do i=1,10
- psurf = (cf1*(ppb(1,i)+pp(1,i)) + cf2*(ppb(2,i)+pp(2,i)) + cf3*(ppb(3,i)+pp(3,i)))/100.
-
- psurf = (ppb(1,i)+pp(1,i)) + .5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+scalars(index_qv,1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+scalars(index_qv,2,i)))
-
- write(0,*) ' i, psurf, lat ',i,psurf,grid%latCell%array(i)*180./3.1415828
- enddo
-
- ! Compute rho and theta from rho_zz and theta_m
- do iCell=1,grid%nCells
- do k=1,grid%nVertLevels
- diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
- diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell))
- end do
- end do
-
- end subroutine atm_test_case_jw
-
- subroutine atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1_in,lat2_in,dvEdge,a,u0,nz1,nlat)
-
- implicit none
- integer, intent(in) :: nz1,nlat
- real (kind=RKIND), dimension(nz1,nlat), intent(in) :: u_2d,etavs_2d
- real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d
- real (kind=RKIND), dimension(nz1), intent(out) :: flux_zonal
- real (kind=RKIND), intent(in) :: lat1_in, lat2_in, dvEdge, a, u0
-
- integer :: k,i
- real (kind=RKIND) :: lat1, lat2, w1, w2
- real (kind=RKIND) :: dlat,da,db
-
- lat1 = abs(lat1_in)
- lat2 = abs(lat2_in)
- if(lat2 <= lat1) then
- lat1 = abs(lat2_in)
- lat2 = abs(lat1_in)
- end if
-
- do k=1,nz1
- flux_zonal(k) = 0.
- end do
-
- do i=1,nlat-1
- if( (lat1 <= lat_2d(i+1)) .and. (lat2 >= lat_2d(i)) ) then
-
- dlat = lat_2d(i+1)-lat_2d(i)
- da = (max(lat1,lat_2d(i))-lat_2d(i))/dlat
- db = (min(lat2,lat_2d(i+1))-lat_2d(i))/dlat
- w1 = (db-da) -0.5*(db-da)**2
- w2 = 0.5*(db-da)**2
-
- do k=1,nz1
- flux_zonal(k) = flux_zonal(k) + w1*u_2d(k,i) + w2*u_2d(k,i+1)
- end do
-
- end if
-
- end do
-
-! renormalize for setting cell-face fluxes
-
- do k=1,nz1
- flux_zonal(k) = sign(1.0_RKIND,lat2_in-lat1_in)*flux_zonal(k)*dlat*a/dvEdge/u0
- end do
-
- end subroutine atm_calc_flux_zonal
-
- !SHP-balance
- subroutine atm_recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz_2d,zx_2d, &
- cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat)
-
- implicit none
- integer, intent(in) :: nz1,nlat
- real (kind=RKIND), dimension(nz1,nlat), intent(inout) :: u_2d
- real (kind=RKIND), dimension(nz1,nlat), intent(in) :: rho_2d, pp_2d, qv_2d, zz_2d
- real (kind=RKIND), dimension(nz1,nlat-1), intent(in) :: zx_2d
- real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d
- real (kind=RKIND), dimension(nz1), intent(in) :: fzm, fzp, rdzw
- real (kind=RKIND), intent(in) :: cf1, cf2, cf3, dlat
-
- !local variable
- real (kind=RKIND), dimension(nz1,nlat-1) :: pgrad, ru, u
- real (kind=RKIND), dimension(nlat-1) :: f
- real (kind=RKIND), dimension(nz1+1) :: dpzx
-
- real (kind=RKIND), parameter :: omega_e = 7.29212e-05
- real (kind=RKIND) :: rdx, qtot, r_earth, phi
- integer :: k,i, itr
-
- r_earth = a
- rdx = 1./(dlat*r_earth)
-
- do i=1,nlat-1
- do k=1,nz1
- pgrad(k,i) = rdx*(pp_2d(k,i+1)/zz_2d(k,i+1)-pp_2d(k,i)/zz_2d(k,i))
- end do
-
- dpzx(:) = 0.
-
- k=1
- dpzx(k) = .5*zx_2d(k,i)*(cf1*(pp_2d(k ,i+1)+pp_2d(k ,i)) &
- +cf2*(pp_2d(k+1,i+1)+pp_2d(k+1,i)) &
- +cf3*(pp_2d(k+2,i+1)+pp_2d(k+2,i)))
- do k=2,nz1
- dpzx(k) = .5*zx_2d(k,i)*(fzm(k)*(pp_2d(k ,i+1)+pp_2d(k ,i)) &
- +fzp(k)*(pp_2d(k-1,i+1)+pp_2d(k-1,i)))
- end do
-
- do k=1,nz1
- pgrad(k,i) = pgrad(k,i) - rdzw(k)*(dpzx(k+1)-dpzx(k))
- end do
- end do
-
-
- !initial value of v and rv -> that is from analytic sln.
- do i=1,nlat-1
- do k=1,nz1
- u(k,i) = .5*(u_2d(k,i)+u_2d(k,i+1))
- ru(k,i) = u(k,i)*(rho_2d(k,i)+rho_2d(k,i+1))*.5
- end do
- end do
-
- write(0,*) "MAX U wind before REBALANCING ---->", maxval(abs(u))
-
- !re-calculate geostrophic wind using iteration
- do itr=1,50
- do i=1,nlat-1
- phi = (lat_2d(i)+lat_2d(i+1))/2.
- f(i) = 2.*omega_e*sin(phi)
- do k=1,nz1
- if (f(i).eq.0.) then
- ru(k,i) = 0.
- else
- qtot = .5*(qv_2d(k,i)+qv_2d(k,i+1))
- ru(k,i) = - ( 1./(1.+qtot)*pgrad(k,i) + tan(phi)/r_earth*u(k,i)*ru(k,i) )/f(i)
- end if
- u(k,i) = ru(k,i)*2./(rho_2d(k,i)+rho_2d(k,i+1))
- end do
- end do
- end do
-
- write(0,*) "MAX U wind after REBALANCING ---->", maxval(abs(u))
-
- !update 2d ru
- do i=2,nlat-1
- do k=1,nz1
- u_2d(k,i) = (ru(k,i-1)+ru(k,i))*.5
- end do
- end do
-
- i=1
- do k=1,nz1
- u_2d(k,i) = (3.*u_2d(k,i+1)-u_2d(k,i+2))*.5
- end do
- i=nlat
- do k=1,nz1
- u_2d(k,i) = (3.*u_2d(k,i-1)-u_2d(k,i-2))*.5
- end do
-
-
- end subroutine atm_recompute_geostrophic_wind
-!----------------------------------------------------------------------------------------------------------
-
- subroutine atm_test_case_squall_line(dminfo, grid, state, diag, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup squall line and supercell test case
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (dm_info), intent(in) :: dminfo
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
- type (diag_type), intent(inout) :: diag
- integer, intent(in) :: test_case
-
- real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
- real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2, nCellsSolve
- integer :: index_qv
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znu, znw, znwc, znwv
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znuc, znuv
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh, thi, tbi, cqwb
-
- real (kind=RKIND) :: r, xnutr
- real (kind=RKIND) :: ztemp, zd, zt, dz, str
-
- real (kind=RKIND), dimension(grid % nVertLevels ) :: qvb
- real (kind=RKIND), dimension(grid % nVertLevels ) :: t_init_1d
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2
- real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, pibtop, ptopb, ptop, rcp, rcv, p0
- real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, yloc, ymid, a_scale
- real (kind=RKIND) :: pres, temp, es, qvs
-
- !
- ! Scale all distances
- !
-
- a_scale = 1.0
-
- grid % xCell % array = grid % xCell % array * a_scale
- grid % yCell % array = grid % yCell % array * a_scale
- grid % zCell % array = grid % zCell % array * a_scale
- grid % xVertex % array = grid % xVertex % array * a_scale
- grid % yVertex % array = grid % yVertex % array * a_scale
- grid % zVertex % array = grid % zVertex % array * a_scale
- grid % xEdge % array = grid % xEdge % array * a_scale
- grid % yEdge % array = grid % yEdge % array * a_scale
- grid % zEdge % array = grid % zEdge % array * a_scale
- grid % dvEdge % array = grid % dvEdge % array * a_scale
- grid % dcEdge % array = grid % dcEdge % array * a_scale
- grid % areaCell % array = grid % areaCell % array * a_scale**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
- nCellsSolve = grid % nCellsSolve
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- ppb => diag % pressure_base % array
- pb => diag % exner_base % array
- rb => diag % rho_base % array
- tb => diag % theta_base % array
- rtb => diag % rtheta_base % array
- p => diag % exner % array
- cqw => diag % cqw % array
-
- rho_zz => state % rho_zz % array
-
- pp => diag % pressure_p % array
- rr => diag % rho_p % array
- t => state % theta_m % array
- rt => diag % rtheta_p % array
- u => state % u % array
- ru => diag % ru % array
-
- scalars => state % scalars % array
-
- index_qv = state % index_qv
-
- scalars(:,:,:) = 0.
-
- call atm_initialize_advection_rk(grid)
- call atm_initialize_deformation_weights(grid)
-
- xnutr = 0.
- zd = 12000.
-
- p0 = 1.e+05
- rcp = rgas/cp
- rcv = rgas/(cp-rgas)
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- hx(k,iCell) = 0. ! squall line or supercell on flat plane
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.0
- zt = 20000.
- dz = zt/float(nz1)
-
-! write(0,*) ' dz = ',dz
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-
-! sh(k) is the stretching specified for height surfaces
-
- zc(k) = zt*(real(k-1)*dz/zt)**str
-
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k)
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
-! zw(k) = float(k-1)*dz
- zw(k) = zc(k)
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
-! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
- ah(k) = 1.
-! write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2)
- COF2 = DZU(2) /(DZU(2)+DZU(3))*DZW(1)/DZU(3)
- CF1 = FZP(2) + COF1
- CF2 = FZM(2) - COF1 - COF2
- CF3 = COF2
-
-! d1 = .5*dzw(1)
-! d2 = dzw(1)+.5*dzw(2)
-! d3 = dzw(1)+dzw(2)+.5*dzw(3)
-! cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-! cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- grid % cf1 % scalar = cf1
- grid % cf2 % scalar = cf2
- grid % cf3 % scalar = cf3
-
- do iCell=1,grid % nCells
- do k=1,nz
- zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
- + (1.-ah(k)) * zc(k)
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
-!
-! convective initialization
-!
- ztr = 12000.
- thetar = 343.
- ttr = 213.
- thetas = 300.5
-
-! write(0,*) ' rgas, cp, gravity ',rgas,cp, gravity
-
- if ( config_test_case == 4) then ! squall line parameters
- um = 12.
- us = 10.
- zts = 2500.
- else if (config_test_case == 5) then !supercell parameters
- um = 30.
- us = 15.
- zts = 5000.
- end if
-
- do i=1,grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- if(ztemp .gt. ztr) then
- t (k,i) = thetar*exp(9.8*(ztemp-ztr)/(1003.*ttr))
- rh(k,i) = 0.25
- else
- t (k,i) = 300.+43.*(ztemp/ztr)**1.25
- rh(k,i) = (1.-0.75*(ztemp/ztr)**1.25)
- if(t(k,i).lt.thetas) t(k,i) = thetas
- end if
- tb(k,i) = t(k,i)
- thi(k,i) = t(k,i)
- tbi(k,i) = t(k,i)
- cqw(k,i) = 1.
- cqwb(k,i) = 1.
- end do
- end do
-
-! rh(:,:) = 0.
-
-! set the velocity field - we are on a plane here.
-
- do i=1, grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) &
- +zgrid(k,cell2)+zgrid(k+1,cell2))
- if(ztemp.lt.zts) then
- u(k,i) = um*ztemp/zts
- else
- u(k,i) = um
- end if
- if(i == 1 ) grid % u_init % array(k) = u(k,i) - us
- u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
- end do
- end if
- end do
-
- call mpas_dmpar_bcast_reals(dminfo, nz1, grid % u_init % array)
-
-!
-! for reference sounding
-!
- do itr=1,30
-
- pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
- pibtop = 1.-.5*dzw(1)*gravity*(1.+qvb(1))/(cp*tb(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t(k,1)+t(k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
- pibtop = pibtop-dzu(k)*gravity/(cp*cqwb(k,1)*.5*(tb(k,1)+tb(k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
-
- !write(0,*) k,pitop,tb(k,1),dzu(k),tb(k,1)
- end do
- pitop = pitop-.5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
- pibtop = pibtop-.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,1)*zz(nz1,1))
-
- call mpas_dmpar_bcast_real(dminfo, pitop)
- call mpas_dmpar_bcast_real(dminfo, pibtop)
-
- ptopb = p0*pibtop**(1./rcp)
- write(6,*) 'ptopb = ',.01*ptopb
-
- do i=1, grid % nCells
- pb(nz1,i) = pibtop+.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,i)*zz(nz1,i))
- p (nz1,i) = pitop+.5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,i))/(cp*t (nz1,i)*zz(nz1,i))
- do k=nz1-1,1,-1
- pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*cqwb(k+1,i)*.5*(tb(k,i)+tb(k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*cqw(k+1,i)*.5*(t (k,i)+t (k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- end do
- do k=1,nz1
- rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
- rtb(k,i) = rb(k,i)*tb(k,i)
- rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
- ppb(k,i) = p0*(zz(k,i)*rgas*rtb(k,i)/p0)**(cp/cv)
- end do
- end do
-
- !
- ! update water vapor mixing ratio from humidity profile
- !
- do i= 1,grid%nCells
- do k=1,nz1
- temp = p(k,i)*thi(k,i)
- pres = p0*p(k,i)**(1./rcp)
- qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,i) = min(0.014_RKIND,rh(k,i)*qvs)
- end do
- end do
-
- do k=1,nz1
-!*********************************************************************
-! QVB = QV INCLUDES MOISTURE IN REFERENCE STATE
-! qvb(k) = scalars(index_qv,k,1)
-
-! QVB = 0 PRODUCES DRY REFERENCE STATE
- qvb(k) = 0.
-!*********************************************************************
- end do
-
- do i= 1,grid%nCells
- do k=1,nz1
- t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i))
- tb(k,i) = tbi(k,i)*(1.+1.61*qvb(k))
- end do
- do k=2,nz1
- cqw (k,i) = 1./(1.+.5*(scalars(index_qv,k,i)+scalars(index_qv,k-1,i)))
- cqwb(k,i) = 1./(1.+.5*(qvb(k)+qvb(k-1)))
- end do
- end do
-
- end do !end of iteration loop
-
- write(0,*) ' base state sounding '
- write(0,*) ' k, pb, rb, tb, rtb, t, rr, p, qvb'
- do k=1,grid%nVertLevels
- write (0,'(i2,8(2x,f19.15))') k,pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvb(k)
- end do
-
-!
-! potential temperature perturbation
-!
-! delt = -10.
-! delt = -0.01
- delt = 3.
- radx = 10000.
- radz = 1500.
- zcent = 1500.
-
- if (config_test_case == 4) then ! squall line prameters
- call mpas_dmpar_max_real(dminfo, maxval(grid % xCell % array(:)), xmid)
- xmid = xmid * 0.5
- ymid = 0.0 ! Not used for squall line
- else if (config_test_case == 5) then ! supercell parameters
- call mpas_dmpar_max_real(dminfo, maxval(grid % xCell % array(:)), xmid)
- call mpas_dmpar_max_real(dminfo, maxval(grid % yCell % array(:)), ymid)
- xmid = xmid * 0.5
- ymid = ymid * 0.5
- end if
-
- do i=1, grid % nCells
- xloc = grid % xCell % array(i) - xmid
- if (config_test_case == 4) then
- yloc = 0. !squall line setting
- else if (config_test_case == 5) then
- yloc = grid % yCell % array(i) - ymid !supercell setting
- end if
-
- do k = 1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- rad =sqrt((xloc/radx)**2+(yloc/radx)**2+((ztemp-zcent)/radz)**2)
- if(rad.lt.1) then
- thi(k,i) = thi(k,i) + delt*cos(.5*pii*rad)**2
- end if
- t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i))
- end do
- end do
-
- do itr=1,30
-
- pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t (k,1)+t (k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
- end do
- pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
- ptop = p0*pitop**(1./rcp)
- write(0,*) 'ptop = ',.01*ptop, .01*ptopb
-
- call mpas_dmpar_bcast_real(dminfo, ptop)
-
- do i = 1, grid % nCells
-
- pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* &
- (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
- do k=nz1-1,1,-1
-! pp(k,i) = pp(k+1,i)+.5*dzu(k+1)*gravity* &
-! (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
-! +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
- pp(k,i) = pp(k+1,i)+dzu(k+1)*gravity*( &
- fzm(k+1)*(rb(k+1,i)*(scalars(index_qv,k+1,i)-qvb(k+1)) &
- +rr(k+1,i)*(1.+scalars(index_qv,k+1,i))) &
- +fzp(k+1)*(rb(k ,i)*(scalars(index_qv,k ,i)-qvb(k)) &
- +rr(k ,i)*(1.+scalars(index_qv,k ,i))))
- end do
- if (itr==1.and.i==1) then
- do k=1,nz1
- write(0,*) "pp-check", pp(k,i)
- end do
- end if
- do k=1,nz1
- rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
- p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
- rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
- end do
-
- end do ! loop over cells
-
- end do ! iteration loop
-!----------------------------------------------------------------------
-!
- do k=1,nz1
- grid % qv_init % array(k) = scalars(index_qv,k,1)
- end do
-
- t_init_1d(:) = t(:,1)
- call mpas_dmpar_bcast_reals(dminfo, nz1, t_init_1d)
- call mpas_dmpar_bcast_reals(dminfo, nz1, grid % qv_init % array)
-
- do i=1,grid % ncells
- do k=1,nz1
- grid % t_init % array(k,i) = t_init_1d(k)
- rho_zz(k,i) = rb(k,i)+rr(k,i)
- end do
- end do
-
- do i=1,grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ru (k,i) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*u(k,i)
- end do
- end if
- end do
-
-
- !
- ! we are assuming w and rw are zero for this initialization
- ! i.e., no terrain
- !
- diag % rw % array = 0.
- state % w % array = 0.
-
- grid % zb % array = 0.
- grid % zb3% array = 0.
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 0.
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 0.
- end do
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- diag % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
- ! write(0,*) ' k,u_init, t_init, qv_init '
- ! do k=1,grid%nVertLevels
- ! write(0,'(i2,3(2x,f14.10)') k,grid % u_init % array(k),grid % t_init% array(k),grid % qv_init % array(k)
- ! end do
-
- ! Compute rho and theta from rho_zz and theta_m
- do iCell=1,grid%nCells
- do k=1,grid%nVertLevels
- diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
- diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell))
- end do
- end do
-
- end subroutine atm_test_case_squall_line
-
-
-!----------------------------------------------------------------------------------------------------------
-
-
- subroutine atm_test_case_mtn_wave(grid, state, diag, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
- type (diag_type), intent(inout) :: diag
- integer, intent(in) :: test_case
-
- real (kind=RKIND), parameter :: t0=288., hm=250.
-
- real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
- real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zb, zb3
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge
- real (kind=RKIND), dimension(:), pointer :: dvEdge, AreaCell, xCell, yCell
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
- integer :: index_qv
-
- real (kind=RKIND) :: ptop, pitop, ptopb, p0, flux, d2fdx2_cell1, d2fdx2_cell2
-
- real (kind=RKIND) :: ztemp, zd, zt, dz, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh
- real (kind=RKIND) :: es, qvs, xnutr, ptemp
- integer :: iter
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
-
- real (kind=RKIND) :: d1, d2, d3, cof1, cof2, cf1, cf2, cf3
- real (kind=RKIND) :: um, us, rcp, rcv
- real (kind=RKIND) :: xmid, temp, pres, a_scale
-
- real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, sm, dzh, dzht, dzmin, z_edge, z_edge3
-
- integer, dimension(grid % nCells, 2) :: next_cell
- real (kind=RKIND), dimension(grid % nCells) :: hxzt
- logical, parameter :: terrain_smooth = .false.
-
- !
- ! Scale all distances
- !
-
- a_scale = 1.0
-
- grid % xCell % array = grid % xCell % array * a_scale
- grid % yCell % array = grid % yCell % array * a_scale
- grid % zCell % array = grid % zCell % array * a_scale
- grid % xVertex % array = grid % xVertex % array * a_scale
- grid % yVertex % array = grid % yVertex % array * a_scale
- grid % zVertex % array = grid % zVertex % array * a_scale
- grid % xEdge % array = grid % xEdge % array * a_scale
- grid % yEdge % array = grid % yEdge % array * a_scale
- grid % zEdge % array = grid % zEdge % array * a_scale
- grid % dvEdge % array = grid % dvEdge % array * a_scale
- grid % dcEdge % array = grid % dcEdge % array * a_scale
- grid % areaCell % array = grid % areaCell % array * a_scale**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- dvEdge => grid % dvEdge % array
- AreaCell => grid % AreaCell % array
- CellsOnEdge => grid % CellsOnEdge % array
- deriv_two => grid % deriv_two % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
- nCellsSolve = grid % nCellsSolve
-
- zgrid => grid % zgrid % array
- zb => grid % zb % array
- zb3 => grid % zb3 % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- xCell => grid % xCell % array
- yCell => grid % yCell % array
-
- ppb => diag % pressure_base % array
- pb => diag % exner_base % array
- rb => diag % rho_base % array
- tb => diag % theta_base % array
- rtb => diag % rtheta_base % array
- p => diag % exner % array
- cqw => diag % cqw % array
-
- rho_zz => state % rho_zz % array
-
- pp => diag % pressure_p % array
- rr => diag % rho_p % array
- t => state % theta_m % array
- rt => diag % rtheta_p % array
- u => state % u % array
- ru => diag % ru % array
-
- scalars => state % scalars % array
-
- index_qv = state % index_qv
-
- scalars(:,:,:) = 0.
-
- call atm_initialize_advection_rk(grid)
- call atm_initialize_deformation_weights(grid)
-
- xnutr = 0.1
- zd = 10500.
-
- p0 = 1.e+05
- rcp = rgas/cp
- rcv = rgas/(cp-rgas)
-
- ! for hx computation
- xa = 5000. !SHP - should be changed based on grid distance
- xla = 4000.
- xc = maxval (grid % xCell % array(:))/2.
-
- ! metrics for hybrid coordinate and vertical stretching
- str = 1.0
- zt = 21000.
- dz = zt/float(nz1)
-! write(0,*) ' dz = ',dz
-
- do k=1,nz
-
-! sh(k) is the stretching specified for height surfaces
-
- zc(k) = zt*(real(k-1)*dz/zt)**str
-
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k)
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
-! zw(k) = float(k-1)*dz
- zw(k) = zc(k)
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
-! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
- ah(k) = 1.
-! write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- d1 = .5*dzw(1)
- d2 = dzw(1)+.5*dzw(2)
- d3 = dzw(1)+dzw(2)+.5*dzw(3)
- !cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- !cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- !cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- cof1 = (2.*dzu(2)+dzu(3))/(dzu(2)+dzu(3))*dzw(1)/dzu(2)
- cof2 = dzu(2) /(dzu(2)+dzu(3))*dzw(1)/dzu(3)
- cf1 = fzp(2) + cof1
- cf2 = fzm(2) - cof1 - cof2
- cf3 = cof2
-
- grid % cf1 % scalar = cf1
- grid % cf2 % scalar = cf2
- grid % cf3 % scalar = cf3
-
-! setting for terrain
- do iCell=1,grid % nCells
- xi = grid % xCell % array(iCell)
- !====1. for pure cosine mountain
- ! if(abs(xi-xc).ge.2.*xa) then
- ! hx(1,iCell) = 0.
- ! else
- ! hx(1,iCell) = hm*cos(.5*pii*(xi-xc)/(2.*xa))**2.
- ! end if
-
- !====2. for cosine mountain
- !if(abs(xi-xc).lt.xa) THEN
- ! hx(1,iCell) = hm*cos(pii*(xi-xc)/xla)**2. *cos(.5*pii*(xi-xc)/xa )**2.
- ! else
- ! hx(1,iCell) = 0.
- ! end if
-
- !====3. for shock mountain
- hx(1,iCell) = hm*exp(-((xi-xc)/xa)**2)*cos(pii*(xi-xc)/xla)**2.
-
- hx(nz,iCell) = zt
-
-!***** SHP -> get the temporary point information for the neighbor cell ->> should be changed!!!!!
- do i=1,grid % nCells
- !option 1
- !IF(yCell(i).eq.yCell(iCell).and.xCell(i).eq.xCell(iCell)-sqrt(3.)*grid % dcEdge % array(1)) next_cell(iCell,1) = i
- !IF(yCell(i).eq.yCell(iCell).and.xCell(i).eq.xCell(iCell)+sqrt(3.)*grid % dcEdge % array(1)) next_cell(iCell,2) = i
- !option 2
- next_cell(iCell,1) = iCell - 8 ! note ny=4
- next_cell(iCell,2) = iCell + 8 ! note ny=4
-
- if (xCell(iCell).le. 3.*grid % dcEdge % array(1)) then
- next_cell(iCell,1) = 1
- else if (xCell(iCell).ge. maxval(xCell(:))-3.*grid % dcEdge % array(1)) then
- next_cell(iCell,2) = 1
- end if
-
- end do
- enddo
-
- write(0,*) ' hx computation complete '
-
-
-! smoothing grid for the upper level >> but not propoer for parallel programing
- dzmin=.7
- do k=2,nz1
- sm = .25*min((zc(k)-zc(k-1))/dz,1.0_RKIND)
- do i=1,grid % nCells
- hx(k,i) = hx(k-1,i)
- end do
-
- do iter = 1,20 !iteration for smoothing
-
- do i=1,grid % nCells
- hxzt(i) = hx(k,i) + sm*(hx(k,next_cell(i,2))-2.*hx(k,i)+hx(k,next_cell(i,1)))
- end do
- dzh = zc(k) - zc(k-1)
- do i=1,grid % nCells
- dzht = zc(k)+hxzt(i) - zc(k-1)-hx(k-1,i)
- if(dzht.lt.dzh) dzh = dzht
- end do
-
- if(dzh.gt.dzmin*(zc(k)-zc(k-1))) then
- do i=1,grid % nCells
- hx(k,i) = hxzt(i)
- end do
- else
- goto 99 !SHP - this algorithm should be changed
- end if
-
- end do !end of iteration for smoothing
-99 write(0,*) "PASS-SHP"
- end do
-
- do iCell=1,grid % nCells
- do k=1,nz
- if (terrain_smooth) then
- zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
- + (1.-ah(k)) * zc(k)
- else
- zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(1,iCell)/zt)+hx(1,iCell)) &
- + (1.-ah(k)) * zc(k)
- end if
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- write(0,*) ' grid metrics setup complete '
-
-!
-! mountain wave initialization
-!
- !SHP-original
- !zinv = 1000.
- !SHP-schar case
- zinv = 3000.
-
- xn2 = 0.0001
- xn2m = 0.0000
- xn2l = 0.0001
-
- um = 10.
- us = 0.
-
- do i=1,grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- tb(k,i) = t0*(1. + xn2m/gravity*ztemp)
- if(ztemp .le. zinv) then
- t (k,i) = t0*(1.+xn2l/gravity*ztemp)
- else
- t (k,i) = t0*(1.+xn2l/gravity*zinv+xn2/gravity*(ztemp-zinv))
- end if
- rh(k,i) = 0.
- end do
- end do
-
-! set the velocity field - we are on a plane here.
-
- do i=1, grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) &
- +zgrid(k,cell2)+zgrid(k+1,cell2))
- u(k,i) = um
- if(i == 1 ) grid % u_init % array(k) = u(k,i) - us
-#ifdef ROTATED_GRID
- u(k,i) = sin(grid % angleEdge % array(i)) * (u(k,i) - us)
-#else
- u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
-#endif
- end do
- end if
- end do
-
-!
-! reference sounding based on dry atmosphere
-!
- pitop = 1.-.5*dzw(1)*gravity/(cp*tb(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*(fzm(k)*tb(k,1)+fzp(k)*tb(k-1,1)) &
- *(fzm(k)*zz(k,1)+fzp(k)*zz(k-1,1)))
- end do
- pitop = pitop-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1))
- ptopb = p0*pitop**(1./rcp)
-
- do i=1, grid % nCells
- pb(nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*tb(nz1,i)*zz(nz1,i))
- p (nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*t (nz1,i)*zz(nz1,i))
- do k=nz1-1,1,-1
- pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*.5*(tb(k,i)+tb(k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*.5*(t (k,i)+t (k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- end do
- do k=1,nz1
- rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
- rtb(k,i) = rb(k,i)*tb(k,i)
- rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
- cqw(k,i) = 1.
- end do
- end do
-
- write(0,*) ' ***** base state sounding ***** '
- write(0,*) 'k pb p rb rtb rr tb t'
- do k=1,grid%nVertLevels
- write(0,'(i2,7(2x,f14.9))') k,pb(k,1),p(k,1),rb(k,1),rtb(k,1),rr(k,1),tb(k,1),t(k,1)
- end do
-
- scalars(index_qv,:,:) = 0.
-
-!-------------------------------------------------------------------
-! ITERATIONS TO CONVERGE MOIST SOUNDING
- do itr=1,30
- pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
-
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*(fzm(k)*t (k,1)+fzp(k)*t (k-1,1)) &
- *(fzm(k)*zz(k,1)+fzp(k)*zz(k-1,1)))
- end do
- pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
- ptop = p0*pitop**(1./rcp)
-
- do i = 1, grid % nCells
-
- pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* &
- (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
- do k=nz1-1,1,-1
- pp(k,i) = pp(k+1,i)+dzu(k+1)*gravity* &
- (fzm(k)*(rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i)) &
- +fzp(k)*(rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i)))
- end do
- do k=1,nz1
- rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
- p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
- rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
- end do
-!
-! update water vapor mixing ratio from humitidty profile
-!
- do k=1,nz1
- temp = p(k,i)*t(k,i)
- pres = p0*p(k,i)**(1./rcp)
- qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,i) = min(0.014_RKIND,rh(k,i)*qvs)
- end do
-
- do k=1,nz1
- t (k,i) = t(k,i)*(1.+1.61*scalars(index_qv,k,i))
- end do
- do k=2,nz1
- cqw(k,i) = 1./(1.+.5*( scalars(index_qv,k-1,i) &
- +scalars(index_qv,k ,i)))
- end do
-
- end do ! loop over cells
-
- end do ! iteration loop
-!----------------------------------------------------------------------
-!
- write(0,*) ' *** sounding for the simulation ***'
- write(0,*) ' z theta pres qv rho_m u rr'
- do k=1,nz1
- write(6,'(8(f14.9,2x))') .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
- t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
- .01*p0*p(k,1)**(1./rcp), &
- 1000.*scalars(index_qv,k,1), &
- (rb(k,1)+rr(k,1))*(1.+scalars(index_qv,k,1)), &
- grid % u_init % array(k), rr(k,1)
- end do
-
- do i=1,grid % ncells
- do k=1,nz1
- rho_zz(k,i) = rb(k,i)+rr(k,i)
- end do
-
- do k=1,nz1
- grid % t_init % array(k,i) = t(k,i)
- end do
- end do
-
- do i=1,grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ru (k,i) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*u(k,i)
- end do
- end if
- end do
-
-!
-! pre-calculation z-metric terms in omega eqn.
-!
- do iEdge = 1,grid % nEdges
- cell1 = CellsOnEdge(1,iEdge)
- cell2 = CellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
-
- do k = 1, grid%nVertLevels
-
- if (config_theta_adv_order == 2) then
-
- z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2.
-
- else !theta_adv_order == 3 or 4
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
- - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
-
- if (config_theta_adv_order == 3) then
- z_edge3 = - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.
- else
- z_edge3 = 0.
- end if
-
- end if
-
- zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/AreaCell(cell1)
- zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/AreaCell(cell2)
- zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
- zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
-
- end do
-
- end if
- end do
-
-! for including terrain
- state % w % array(:,:) = 0.0
- diag % rw % array(:,:) = 0.0
-
-!
-! calculation of omega, rw = zx * ru + zz * rw
-!
-
- do iEdge = 1,grid % nEdges
-
- cell1 = CellsOnEdge(1,iEdge)
- cell2 = CellsOnEdge(2,iEdge)
-
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
- do k = 2, grid%nVertLevels
- flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge))
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)*flux
-
- if (config_theta_adv_order ==3) then
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
- - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* &
- (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
- + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* &
- (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)*flux
- end if
-
- end do
- end if
-
- end do
-
- ! Compute w from rho_zz and rw
- do iCell=1,grid%nCells
- do k=2,grid%nVertLevels
- state % w % array(k,iCell) = diag % rw % array(k,iCell) &
- / (fzp(k) * state % rho_zz % array(k-1,iCell) + fzm(k) * state % rho_zz % array(k,iCell))
- end do
- end do
-
-
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 0.
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 0.
- end do
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- diag % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
-! do k=1,grid%nVertLevels
-! write(0,*) ' k,u_init, t_init, qv_init ',k,grid % u_init % array(k),grid % t_init% array(k),grid % qv_init % array(k)
-! end do
-
- ! Compute rho and theta from rho_zz and theta_m
- do iCell=1,grid%nCells
- do k=1,grid%nVertLevels
- diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
- diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell))
- end do
- end do
-
- end subroutine atm_test_case_mtn_wave
-
-
-!----------------------------------------------------------------------------------------------------------
-
- real (kind=RKIND) function sphere_distance(lat1, lon1, lat2, lon2, radius)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
- ! sphere with given radius.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
-
- real (kind=RKIND) :: arg1
-
- arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
- cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
- sphere_distance = 2.*radius*asin(arg1)
-
- end function sphere_distance
-
-!--------------------------------------------------------------------
- real (kind=RKIND) function env_qv( z, temperature, pressure, rh_max )
-
- implicit none
- real (kind=RKIND) :: z, temperature, pressure, ztr, es, qvs, p0, rh_max
-
- p0 = 100000.
-
-! ztr = 5000.
-!
-! if(z .gt. ztr) then
-! env_qv = 0.
-! else
-! if(z.lt.2000.) then
-! env_qv = .5
-! else
-! env_qv = .5*(1.-(z-2000.)/(ztr-2000.))
-! end if
-! end if
-
- if (pressure .lt. 50000. ) then
- env_qv = 0.0
- else
- env_qv = (1.-((p0-pressure)/50000.)**1.25)
- end if
-
- env_qv = min(rh_max,env_qv)
-
-! env_qv is the relative humidity, turn it into mixing ratio
- if (temperature .gt. 273.15) then
- es = 1000.*0.6112*exp(17.67*(temperature-273.15)/(temperature-29.65))
- else
- es = 1000.*0.6112*exp(21.8745584*(temperature-273.16)/(temperature-7.66))
- end if
- qvs = (287.04/461.6)*es/(pressure-es)
-
- ! qvs = 380.*exp(17.27*(temperature-273.)/(temperature-36.))/pressure
-
- env_qv = env_qv*qvs
-
- end function env_qv
-
-end module atm_test_cases
Modified: branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_time_integration.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_time_integration.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_nhyd_atmos/mpas_atm_time_integration.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1326,7 +1326,7 @@
wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell))
end do
end do
- do k=1,grid % nVertLevelsSolve
+ do k=1,grid % nVertLevels ! Could be nVertLevelsSolve?
do iScalar=1,s_old % num_scalars
scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*h_old(k,iCell) &
+ dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) )/h_new(k,iCell)
@@ -1355,7 +1355,7 @@
wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell))
enddo
- do k=1,grid % nVertLevelsSolve
+ do k=1,grid % nVertLevels ! Could be nVertLevelsSolve?
do iScalar=1,s_old % num_scalars
scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*h_old(k,iCell) &
+ dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) )/h_new(k,iCell)
@@ -1383,7 +1383,7 @@
wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell))
enddo
- do k=1,grid % nVertLevelsSolve
+ do k=1,grid % nVertLevels ! Could be nVertLevelsSolve?
do iScalar=1,s_old % num_scalars
scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*h_old(k,iCell) &
+ dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) )/h_new(k,iCell)
@@ -1865,12 +1865,11 @@
!SHP-curvature
logical, parameter :: curvature = .true.
- real (kind=RKIND), parameter :: omega_e = 7.29212e-05
real (kind=RKIND) :: r_earth
real (kind=RKIND), dimension(:,:), pointer :: ur_cell, vr_cell
real (kind=RKIND), parameter :: c_s = 0.125
-! real (kind=RKIND), parameter :: c_s = 0.25
+! real (kind=RKIND), parameter :: c_s = 0.25
real (kind=RKIND), dimension( grid % nVertLevels ) :: d_diag, d_off_diag, flux_arr
real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b
logical :: delsq_horiz_mixing, newpx
@@ -1891,7 +1890,7 @@
!-----------
!SHP-curvature
- r_earth = a
+ r_earth = grid % sphere_radius
ur_cell => diag % uReconstructZonal % array
vr_cell => diag % uReconstructMeridional % array
@@ -2152,10 +2151,19 @@
tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(k,iEdge)* (q(k) - (ke(k,cell2) - ke(k,cell1)) &
/ dcEdge(iEdge)) &
- u(k,iEdge)*0.5*(divergence_ru(k,cell1)+divergence_ru(k,cell2))
+ !SHP-curvature
+ if (curvature) then
tend_u(k,iEdge) = tend_u(k,iEdge) &
- - 2.*omega_e*cos(grid % angleEdge % array(iEdge))*cos(grid % latEdge % array(iEdge)) &
- *.25*(rw(k,cell1)+rw(k+1,cell1)+rw(k,cell2)+rw(k+1,cell2)) &
- - u(k,iEdge)*.25*(rw(k+1,cell1)+rw(k,cell1)+rw(k,cell2)+rw(k+1,cell2))/r_earth
+ - 2.*omega*cos(grid % angleEdge % array(iEdge))*cos(grid % latEdge % array(iEdge)) &
+ *rho_edge(k,iEdge)*.25*(w(k,cell1)+w(k+1,cell1)+w(k,cell2)+w(k+1,cell2)) &
+ - u(k,iEdge)*.25*(w(k+1,cell1)+w(k,cell1)+w(k,cell2)+w(k+1,cell2)) &
+ *rho_edge(k,iEdge)/r_earth
+ !old-err.
+ !tend_u(k,iEdge) = tend_u(k,iEdge) &
+ ! - 2.*omega_e*cos(grid % angleEdge % array(iEdge))*cos(grid % latEdge % array(iEdge)) &
+ ! *.25*(rw(k,cell1)+rw(k+1,cell1)+rw(k,cell2)+rw(k+1,cell2)) &
+ ! - u(k,iEdge)*.25*(rw(k+1,cell1)+rw(k,cell1)+rw(k,cell2)+rw(k+1,cell2))/r_earth
+ end if
end do
end do
@@ -2506,12 +2514,19 @@
do iCell = 1, grid % nCellsSolve
do k=2,nVertLevels
- tend_w(k,iCell) = tend_w(k,iCell) &
- + rho_zz(k,iCell)*( (fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell))**2. &
- +(fzm(k)*vr_cell(k,iCell)+fzp(k)*vr_cell(k-1,iCell))**2. )/r_earth &
- + 2.*omega_e*cos(grid % latCell % array(iCell))*rho_zz(k,iCell) &
- *(fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell))
+ tend_w(k,iCell) = tend_w(k,iCell) + (rho_zz(k,iCell)*fzm(k)+rho_zz(k-1,iCell)*fzp(k))* &
+ ( (fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell))**2. &
+ +(fzm(k)*vr_cell(k,iCell)+fzp(k)*vr_cell(k-1,iCell))**2. )/r_earth &
+ + 2.*omega*cos(grid % latCell % array(iCell)) &
+ *(fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell)) &
+ *(rho_zz(k,iCell)*fzm(k)+rho_zz(k-1,iCell)*fzp(k))
+ !old_err.
+ !tend_w(k,iCell) = tend_w(k,iCell) &
+ ! + rho_zz(k,iCell)*( (fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell))**2. &
+ ! +(fzm(k)*vr_cell(k,iCell)+fzp(k)*vr_cell(k-1,iCell))**2. )/r_earth &
+ ! + 2.*omega_e*cos(grid % latCell % array(iCell))*rho_zz(k,iCell) &
+ ! *(fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell))
end do
end do
Index: branches/ocean_projects/shared_advection/src/core_ocean
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean 2013-03-08 17:10:33 UTC (rev 2572)
Property changes on: branches/ocean_projects/shared_advection/src/core_ocean
___________________________________________________________________
Added: svn:mergeinfo
## -0,0 +1,36 ##
+/branches/atmos_physics/src/core_ocean:1672-1846
+/branches/cam_mpas_nh/src/core_ocean:1260-1270
+/branches/ocean_projects/ale_split_exp/src/core_ocean:1437-1483
+/branches/ocean_projects/ale_vert_coord/src/core_ocean:1225-1383
+/branches/ocean_projects/ale_vert_coord_new/src/core_ocean:1387-1428
+/branches/ocean_projects/cesm_coupling/src/core_ocean:2147-2344
+/branches/ocean_projects/diagnostics_revision/src/core_ocean:2439-2462
+/branches/ocean_projects/explicit_vmix_removal/src/core_ocean:2486-2490
+/branches/ocean_projects/gmvar/src/core_ocean:1214-1514,1517-1738
+/branches/ocean_projects/imp_vert_mix_error/src/core_ocean:1847-1887
+/branches/ocean_projects/imp_vert_mix_mrp/src/core_ocean:754-986
+/branches/ocean_projects/leith_mrp/src/core_ocean:2182-2241
+/branches/ocean_projects/linear_eos/src/core_ocean:2435-2437
+/branches/ocean_projects/monotonic_advection/src/core_ocean:1499-1640
+/branches/ocean_projects/monthly_forcing/src/core_ocean:1810-1867
+/branches/ocean_projects/namelist_cleanup/src/core_ocean:2319-2414
+/branches/ocean_projects/option3_b4b_test/src/core_ocean:2201-2231
+/branches/ocean_projects/partial_bottom_cells/src/core_ocean:2172-2226
+/branches/ocean_projects/remove_sw_test_cases/src/core_ocean:2539-2540
+/branches/ocean_projects/restart_reproducibility/src/core_ocean:2239-2272
+/branches/ocean_projects/sea_level_pressure/src/core_ocean:2488-2528
+/branches/ocean_projects/split_explicit_mrp/src/core_ocean:1134-1138
+/branches/ocean_projects/split_explicit_timestepping/src/core_ocean:1044-1097
+/branches/ocean_projects/vert_adv_mrp/src/core_ocean:704-745
+/branches/ocean_projects/vol_cons_RK_imp_mix/src/core_ocean:1965-1992
+/branches/ocean_projects/zstar_restart_new/src/core_ocean:1762-1770
+/branches/omp_blocks/block_decomp/src/core_ocean:1374-1569
+/branches/omp_blocks/ddt_reorg/src/core_ocean:1301-1414
+/branches/omp_blocks/halo/src/core_ocean:1570-1638
+/branches/omp_blocks/io/src/core_ocean:1639-1787
+/branches/omp_blocks/multiple_blocks/src/core_ocean:1803-2084
+/branches/omp_blocks/openmp_test/src/core_ocean:2107-2144
+/branches/omp_blocks/openmp_test/src/core_ocean_elements:2161-2201
+/branches/source_renaming/src/core_ocean:1082-1113
+/branches/time_manager/src/core_ocean:924-962
+/trunk/mpas/src/core_ocean:2091-2563
\ No newline at end of property
Modified: branches/ocean_projects/shared_advection/src/core_ocean/Makefile
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/Makefile 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/Makefile 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,70 +1,59 @@
.SUFFIXES: .F .o
OBJS = mpas_ocn_mpas_core.o \
- mpas_ocn_test_cases.o \
mpas_ocn_advection.o \
- mpas_ocn_thick_hadv.o \
- mpas_ocn_thick_vadv.o \
+ mpas_ocn_thick_hadv.o \
+ mpas_ocn_thick_vadv.o \
mpas_ocn_gm.o \
- mpas_ocn_vel_coriolis.o \
- mpas_ocn_vel_vadv.o \
- mpas_ocn_vel_hmix.o \
- mpas_ocn_vel_hmix_del2.o \
- mpas_ocn_vel_hmix_del4.o \
- mpas_ocn_vel_forcing.o \
- mpas_ocn_vel_forcing_windstress.o \
- mpas_ocn_vel_forcing_bottomdrag.o \
- mpas_ocn_vel_forcing_rayleigh.o \
- mpas_ocn_vel_pressure_grad.o \
- mpas_ocn_tracer_vadv.o \
- mpas_ocn_tracer_vadv_spline.o \
- mpas_ocn_tracer_vadv_spline2.o \
- mpas_ocn_tracer_vadv_spline3.o \
- mpas_ocn_tracer_vadv_stencil.o \
- mpas_ocn_tracer_vadv_stencil2.o \
- mpas_ocn_tracer_vadv_stencil3.o \
- mpas_ocn_tracer_vadv_stencil4.o \
- mpas_ocn_tracer_hadv.o \
- mpas_ocn_tracer_hadv2.o \
- mpas_ocn_tracer_hadv3.o \
- mpas_ocn_tracer_hadv4.o \
- mpas_ocn_tracer_hmix.o \
- mpas_ocn_tracer_hmix_del2.o \
- mpas_ocn_tracer_hmix_del4.o \
- mpas_ocn_vmix.o \
- mpas_ocn_vmix_coefs_const.o \
- mpas_ocn_vmix_coefs_rich.o \
- mpas_ocn_vmix_coefs_tanh.o \
- mpas_ocn_restoring.o \
- mpas_ocn_tendency.o \
- mpas_ocn_tracer_advection.o \
+ mpas_ocn_vel_coriolis.o \
+ mpas_ocn_vel_vadv.o \
+ mpas_ocn_vel_hmix.o \
+ mpas_ocn_vel_hmix_del2.o \
+ mpas_ocn_vel_hmix_leith.o \
+ mpas_ocn_vel_hmix_del4.o \
+ mpas_ocn_vel_forcing.o \
+ mpas_ocn_vel_forcing_windstress.o \
+ mpas_ocn_vel_forcing_rayleigh.o \
+ mpas_ocn_vel_pressure_grad.o \
+ mpas_ocn_tracer_hmix.o \
+ mpas_ocn_tracer_hmix_del2.o \
+ mpas_ocn_tracer_hmix_del4.o \
+ mpas_ocn_vmix.o \
+ mpas_ocn_vmix_coefs_const.o \
+ mpas_ocn_vmix_coefs_rich.o \
+ mpas_ocn_vmix_coefs_tanh.o \
+ mpas_ocn_restoring.o \
+ mpas_ocn_tendency.o \
+ mpas_ocn_diagnostics.o \
+ mpas_ocn_tracer_advection.o \
mpas_ocn_time_integration.o \
mpas_ocn_time_integration_rk4.o \
mpas_ocn_time_integration_split.o \
- mpas_ocn_equation_of_state.o \
- mpas_ocn_equation_of_state_jm.o \
- mpas_ocn_equation_of_state_linear.o \
+ mpas_ocn_equation_of_state.o \
+ mpas_ocn_equation_of_state_jm.o \
+ mpas_ocn_equation_of_state_linear.o \
+ mpas_ocn_diagnostics.o \
mpas_ocn_global_diagnostics.o \
- mpas_ocn_time_average.o \
- mpas_ocn_monthly_forcing.o
+ mpas_ocn_time_average.o \
+ mpas_ocn_monthly_forcing.o
-all: core_hyd
+all: core_ocean
-core_hyd: $(OBJS)
+core_ocean: $(OBJS)
ar -ru libdycore.a $(OBJS)
-mpas_ocn_test_cases.o:
-
mpas_ocn_advection.o:
mpas_ocn_time_integration.o: mpas_ocn_time_integration_rk4.o mpas_ocn_time_integration_split.o
-mpas_ocn_time_integration_rk4.o:
+mpas_ocn_time_integration_rk4.o: mpas_ocn_tendency.o mpas_ocn_diagnostics.o
-mpas_ocn_time_integration_split.o:
+mpas_ocn_time_integration_split.o: mpas_ocn_tendency.o mpas_ocn_diagnostics.o
mpas_ocn_tendency.o: mpas_ocn_time_average.o
+mpas_ocn_diagnostics.o: mpas_ocn_time_average.o
+
mpas_ocn_global_diagnostics.o:
mpas_ocn_time_average.o:
@@ -79,46 +68,22 @@
mpas_ocn_vel_vadv.o:
-mpas_ocn_vel_hmix.o: mpas_ocn_vel_hmix_del2.o mpas_ocn_vel_hmix_del4.o
+mpas_ocn_vel_hmix.o: mpas_ocn_vel_hmix_del2.o mpas_ocn_vel_hmix_leith.o mpas_ocn_vel_hmix_del4.o
mpas_ocn_vel_hmix_del2.o:
+mpas_ocn_vel_hmix_leith.o:
+
mpas_ocn_vel_hmix_del4.o:
-mpas_ocn_vel_forcing.o: mpas_ocn_vel_forcing_windstress.o mpas_ocn_vel_forcing_bottomdrag.o mpas_ocn_vel_forcing_rayleigh.o
+mpas_ocn_vel_forcing.o: mpas_ocn_vel_forcing_windstress.o mpas_ocn_vel_forcing_rayleigh.o
mpas_ocn_vel_forcing_windstress.o:
-mpas_ocn_vel_forcing_bottomdrag.o:
-
mpas_ocn_vel_forcing_rayleigh.o:
mpas_ocn_vel_coriolis.o:
-mpas_ocn_tracer_hadv.o: mpas_ocn_tracer_hadv2.o mpas_ocn_tracer_hadv3.o mpas_ocn_tracer_hadv4.o
-
-mpas_ocn_tracer_hadv2.o:
-
-mpas_ocn_tracer_hadv3.o:
-
-mpas_ocn_tracer_hadv4.o:
-
-mpas_ocn_tracer_vadv.o: mpas_ocn_tracer_vadv_spline.o mpas_ocn_tracer_vadv_stencil.o
-
-mpas_ocn_tracer_vadv_spline.o: mpas_ocn_tracer_vadv_spline2.o mpas_ocn_tracer_vadv_spline3.o
-
-mpas_ocn_tracer_vadv_spline2.o:
-
-mpas_ocn_tracer_vadv_spline3.o:
-
-mpas_ocn_tracer_vadv_stencil.o: mpas_ocn_tracer_vadv_stencil2.o mpas_ocn_tracer_vadv_stencil3.o mpas_ocn_tracer_vadv_stencil4.o
-
-mpas_ocn_tracer_vadv_stencil2.o:
-
-mpas_ocn_tracer_vadv_stencil3.o:
-
-mpas_ocn_tracer_vadv_stencil4.o:
-
mpas_ocn_tracer_hmix.o: mpas_ocn_tracer_hmix_del2.o mpas_ocn_tracer_hmix_del4.o
mpas_ocn_tracer_hmix_del2.o:
@@ -145,52 +110,39 @@
mpas_ocn_monthly_forcing.o:
-mpas_ocn_mpas_core.o: mpas_ocn_mpas_core.o \
- mpas_ocn_test_cases.o \
- mpas_ocn_advection.o \
- mpas_ocn_thick_hadv.o \
+mpas_ocn_mpas_core.o: mpas_ocn_advection.o \
+ mpas_ocn_thick_hadv.o \
mpas_ocn_gm.o \
- mpas_ocn_thick_vadv.o \
- mpas_ocn_vel_coriolis.o \
- mpas_ocn_vel_vadv.o \
- mpas_ocn_vel_hmix.o \
- mpas_ocn_vel_hmix_del2.o \
- mpas_ocn_vel_hmix_del4.o \
- mpas_ocn_vel_forcing.o \
- mpas_ocn_vel_forcing_windstress.o \
- mpas_ocn_vel_forcing_bottomdrag.o \
- mpas_ocn_vel_pressure_grad.o \
- mpas_ocn_tracer_vadv.o \
- mpas_ocn_tracer_vadv_spline.o \
- mpas_ocn_tracer_vadv_spline2.o \
- mpas_ocn_tracer_vadv_spline3.o \
- mpas_ocn_tracer_vadv_stencil.o \
- mpas_ocn_tracer_vadv_stencil2.o \
- mpas_ocn_tracer_vadv_stencil3.o \
- mpas_ocn_tracer_vadv_stencil4.o \
- mpas_ocn_tracer_hadv.o \
- mpas_ocn_tracer_hadv2.o \
- mpas_ocn_tracer_hadv3.o \
- mpas_ocn_tracer_hadv4.o \
+ mpas_ocn_thick_vadv.o \
+ mpas_ocn_vel_coriolis.o \
+ mpas_ocn_vel_vadv.o \
+ mpas_ocn_vel_hmix.o \
+ mpas_ocn_vel_hmix_del2.o \
+ mpas_ocn_vel_hmix_leith.o \
+ mpas_ocn_vel_hmix_del4.o \
+ mpas_ocn_vel_forcing.o \
+ mpas_ocn_vel_forcing_windstress.o \
+ mpas_ocn_vel_pressure_grad.o \
+ mpas_ocn_tracer_advection.o \
mpas_ocn_tracer_hmix.o \
mpas_ocn_tracer_hmix_del2.o \
mpas_ocn_tracer_hmix_del4.o \
- mpas_ocn_vmix.o \
- mpas_ocn_vmix_coefs_const.o \
- mpas_ocn_vmix_coefs_rich.o \
- mpas_ocn_vmix_coefs_tanh.o \
- mpas_ocn_restoring.o \
- mpas_ocn_tracer_advection.o \
- mpas_ocn_tendency.o \
- mpas_ocn_time_integration.o \
- mpas_ocn_time_integration_rk4.o \
- mpas_ocn_time_integration_split.o \
- mpas_ocn_equation_of_state.o \
- mpas_ocn_equation_of_state_jm.o \
- mpas_ocn_equation_of_state_linear.o \
- mpas_ocn_global_diagnostics.o \
- mpas_ocn_time_average.o \
- mpas_ocn_monthly_forcing.o
+ mpas_ocn_vmix.o \
+ mpas_ocn_vmix_coefs_const.o \
+ mpas_ocn_vmix_coefs_rich.o \
+ mpas_ocn_vmix_coefs_tanh.o \
+ mpas_ocn_restoring.o \
+ mpas_ocn_tendency.o \
+ mpas_ocn_diagnostics.o \
+ mpas_ocn_time_integration.o \
+ mpas_ocn_time_integration_rk4.o \
+ mpas_ocn_time_integration_split.o \
+ mpas_ocn_equation_of_state.o \
+ mpas_ocn_equation_of_state_jm.o \
+ mpas_ocn_equation_of_state_linear.o \
+ mpas_ocn_global_diagnostics.o \
+ mpas_ocn_time_average.o \
+ mpas_ocn_monthly_forcing.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/ocean_projects/shared_advection/src/core_ocean/Registry
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/Registry 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/Registry 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,93 +1,147 @@
%
% namelist type namelist_record name default_value
%
-namelist integer sw_model config_test_case 5
-namelist character sw_model config_time_integration RK4
-namelist logical sw_model config_rk_filter_btr_mode false
-namelist real sw_model config_dt 172.8
-namelist character sw_model config_calendar_type 360day
-namelist character sw_model config_start_time 0000-01-01_00:00:00
-namelist character sw_model config_stop_time none
-namelist character sw_model config_run_duration none
-namelist integer sw_model config_stats_interval 100
-namelist logical sw_model config_initial_stats false
-namelist logical sw_model config_prescribe_velocity false
-namelist logical sw_model config_prescribe_thickness false
-namelist integer sw_model config_num_halos 3
-namelist character io config_input_name grid.nc
-namelist character io config_output_name output.nc
-namelist character io config_restart_name restart.nc
-namelist character io config_output_interval 24:00:00
-namelist integer io config_frames_per_outfile 0
-namelist integer io config_pio_num_iotasks 0
-namelist integer io config_pio_stride 1
-namelist character decomposition config_block_decomp_file_prefix graph.info.part.
+namelist logical time_management config_do_restart .false.
+namelist character time_management config_start_time '0000-01-01_00:00:00'
+namelist character time_management config_stop_time 'none'
+namelist character time_management config_run_duration '0_06:00:00'
+namelist character time_management config_calendar_type '360day'
+
+namelist character io config_input_name 'grid.nc'
+namelist character io config_output_name 'output.nc'
+namelist character io config_restart_name 'restart.nc'
+namelist character io config_restart_interval '0_06:00:00'
+namelist character io config_output_interval '0_06:00:00'
+namelist character io config_stats_interval '0_01:00:00'
+namelist logical io config_write_stats_on_startup .true.
+namelist logical io config_write_output_on_startup .true.
+namelist integer io config_frames_per_outfile 1000
+namelist integer io config_pio_num_iotasks 0
+namelist integer io config_pio_stride 1
+
+namelist real time_integration config_dt 3000.0
+namelist character time_integration config_time_integrator 'split_explicit'
+
+namelist integer grid config_num_halos 3
+namelist character grid config_vert_coord_movement 'uniform_stretching'
+namelist character grid config_alter_ICs_for_pbcs 'zlevel_pbcs_off'
+namelist real grid config_min_pbc_fraction 0.10
+namelist logical grid config_check_ssh_consistency .true.
+namelist logical grid config_dzdk_positive .false.
+
+namelist character decomposition config_block_decomp_file_prefix 'graph.info.part.'
namelist integer decomposition config_number_of_blocks 0
namelist logical decomposition config_explicit_proc_decomp .false.
-namelist character decomposition config_proc_decomp_file_prefix graph.info.part.
-namelist logical restart config_do_restart false
-namelist character restart config_restart_interval none
-namelist character grid config_vert_grid_type isopycnal
-namelist character grid config_pressure_type pressure
-namelist real grid config_rho0 1028
-namelist logical grid config_enforce_zstar_at_restart false
-namelist logical grid config_dzdk_positive false
-namelist integer split_explicit_ts config_n_ts_iter 2
-namelist integer split_explicit_ts config_n_bcl_iter_beg 2
-namelist integer split_explicit_ts config_n_bcl_iter_mid 2
-namelist integer split_explicit_ts config_n_bcl_iter_end 2
-namelist integer split_explicit_ts config_n_btr_subcycles 20
-namelist integer split_explicit_ts config_n_btr_cor_iter 2
-namelist logical split_explicit_ts config_u_correction true
-namelist logical split_explicit_ts config_filter_btr_mode false
-namelist integer split_explicit_ts config_btr_subcycle_loop_factor 2
-namelist real split_explicit_ts config_btr_gam1_uWt1 0.5
-namelist real split_explicit_ts config_btr_gam2_SSHWt1 1.0
-namelist real split_explicit_ts config_btr_gam3_uWt2 1.0
-namelist logical split_explicit_ts config_btr_solve_SSH2 false
-namelist logical hmix config_h_ScaleWithMesh false
-namelist real hmix config_h_mom_eddy_visc2 0.0
-namelist real hmix config_h_mom_eddy_visc4 0.0
-namelist logical hmix config_visc_vorticity_term true
-namelist real hmix config_visc_vorticity_visc2_scale 1.0
-namelist real hmix config_visc_vorticity_visc4_scale 1.0
-namelist logical hmix config_include_KE_vertex false
-namelist real hmix config_h_tracer_eddy_diff2 0.0
-namelist real hmix config_h_tracer_eddy_diff4 0.0
-namelist real hmix config_h_kappa 0.0
-namelist real hmix config_h_kappa_q 0.0
-namelist logical hmix config_rayleigh_friction false
-namelist real hmix config_rayleigh_damping_coeff 0.0
-namelist real hmix config_apvm_scale_factor 0.0
-namelist character vmix config_vert_visc_type const
-namelist character vmix config_vert_diff_type const
-namelist logical vmix config_implicit_vertical_mix .true.
+namelist character decomposition config_proc_decomp_file_prefix 'graph.info.part.'
+
+namelist logical hmix config_hmix_ScaleWithMesh .false.
+namelist logical hmix config_visc_vorticity_term .true.
+namelist real hmix config_apvm_scale_factor 0.0
+
+namelist logical hmix_del2 config_use_mom_del2 .false.
+namelist logical hmix_del2 config_use_tracer_del2 .false.
+namelist real hmix_del2 config_mom_del2 0.0
+namelist real hmix_del2 config_tracer_del2 0.0
+namelist real hmix_del2 config_vorticity_del2_scale 1.0
+
+namelist logical hmix_del4 config_use_mom_del4 .true.
+namelist logical hmix_del4 config_use_tracer_del4 .false.
+namelist real hmix_del4 config_mom_del4 5.0e13
+namelist real hmix_del4 config_tracer_del4 0.0
+namelist real hmix_del4 config_vorticity_del4_scale 1.0
+
+namelist logical hmix_Leith config_use_Leith_del2 .false.
+namelist real hmix_Leith config_Leith_parameter 1.0
+namelist real hmix_Leith config_Leith_dx 15000.0
+namelist real hmix_Leith config_Leith_visc2_max 2.5e3
+
+namelist real standard_GM config_h_kappa 0.0
+namelist real standard_GM config_h_kappa_q 0.0
+
+namelist logical Rayleigh_damping config_Rayleigh_friction .false.
+namelist real Rayleigh_damping config_Rayleigh_damping_coeff 0.0
+
namelist real vmix config_convective_visc 1.0
namelist real vmix config_convective_diff 1.0
-namelist real vmix config_bottom_drag_coeff 1.0e-3
+
+namelist logical vmix_const config_use_const_visc .false.
+namelist logical vmix_const config_use_const_diff .false.
namelist real vmix_const config_vert_visc 2.5e-4
namelist real vmix_const config_vert_diff 2.5e-5
+
+namelist logical vmix_rich config_use_rich_visc .true.
+namelist logical vmix_rich config_use_rich_diff .true.
namelist real vmix_rich config_bkrd_vert_visc 1.0e-4
namelist real vmix_rich config_bkrd_vert_diff 1.0e-5
namelist real vmix_rich config_rich_mix 0.005
+
+namelist logical vmix_tanh config_use_tanh_visc .false.
+namelist logical vmix_tanh config_use_tanh_diff .false.
namelist real vmix_tanh config_max_visc_tanh 2.5e-1
namelist real vmix_tanh config_min_visc_tanh 1.0e-4
namelist real vmix_tanh config_max_diff_tanh 2.5e-2
namelist real vmix_tanh config_min_diff_tanh 1.0e-5
namelist real vmix_tanh config_zMid_tanh -100
namelist real vmix_tanh config_zWidth_tanh 100
-namelist character eos config_eos_type linear
-namelist integer advection config_vert_tracer_adv_order 4
-namelist integer advection config_horiz_tracer_adv_order 2
-namelist integer advection config_thickness_adv_order 2
+
+namelist logical forcing config_use_monthly_forcing .false.
+namelist logical forcing config_restoreTS .false.
+namelist real forcing config_restoreT_timescale 90.0
+namelist real forcing config_restoreS_timescale 90.0
+
+namelist character advection config_vert_tracer_adv 'stencil'
+namelist integer advection config_vert_tracer_adv_order 3
+namelist integer advection config_horiz_tracer_adv_order 3
namelist real advection config_coef_3rd_order 0.25
-namelist logical advection config_monotonic false
-namelist logical advection config_check_monotonicity false
-namelist logical restore config_restoreTS false
-namelist real restore config_restoreT_timescale 90.0
-namelist real restore config_restoreS_timescale 90.0
-namelist logical restore config_use_monthly_forcing false
+namelist logical advection config_monotonic .true.
+namelist real bottom_drag config_bottom_drag_coeff 1.0e-3
+
+namelist character pressure_gradient config_pressure_gradient_type 'pressure_and_zmid'
+namelist real pressure_gradient config_rho0 1014.65
+
+namelist character eos config_eos_type 'jm'
+
+namelist real eos_linear config_eos_linear_alpha 2.55e-1
+namelist real eos_linear config_eos_linear_beta 7.64e-1
+namelist real eos_linear config_eos_linear_Tref 19.0
+namelist real eos_linear config_eos_linear_Sref 35.0
+namelist real eos_linear config_eos_linear_rhoref 1025.022
+
+namelist integer split_explicit_ts config_n_ts_iter 2
+namelist integer split_explicit_ts config_n_bcl_iter_beg 1
+namelist integer split_explicit_ts config_n_bcl_iter_mid 2
+namelist integer split_explicit_ts config_n_bcl_iter_end 2
+namelist integer split_explicit_ts config_n_btr_subcycles 20
+namelist integer split_explicit_ts config_n_btr_cor_iter 2
+namelist logical split_explicit_ts config_u_correction .true.
+namelist integer split_explicit_ts config_btr_subcycle_loop_factor 2
+namelist real split_explicit_ts config_btr_gam1_uWt1 0.5
+namelist real split_explicit_ts config_btr_gam2_SSHWt1 1.0
+namelist real split_explicit_ts config_btr_gam3_uWt2 1.0
+namelist logical split_explicit_ts config_btr_solve_SSH2 .false.
+
+namelist logical debug config_check_zlevel_consistency .false.
+namelist logical debug config_filter_btr_mode .false.
+namelist logical debug config_prescribe_velocity .false.
+namelist logical debug config_prescribe_thickness .false.
+namelist logical debug config_include_KE_vertex .false.
+namelist logical debug config_check_tracer_monotonicity .false.
+namelist logical debug config_disable_h_all_tend .false.
+namelist logical debug config_disable_h_hadv .false.
+namelist logical debug config_disable_h_vadv .false.
+namelist logical debug config_disable_u_all_tend .false.
+namelist logical debug config_disable_u_coriolis .false.
+namelist logical debug config_disable_u_pgrad .false.
+namelist logical debug config_disable_u_hmix .false.
+namelist logical debug config_disable_u_windstress .false.
+namelist logical debug config_disable_u_vmix .false.
+namelist logical debug config_disable_u_vadv .false.
+namelist logical debug config_disable_tr_all_tend .false.
+namelist logical debug config_disable_tr_adv .false.
+namelist logical debug config_disable_tr_hmix .false.
+namelist logical debug config_disable_tr_vmix .false.
+
%
% dim type name_in_file name_in_code
%
@@ -152,7 +206,7 @@
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 persistent real cellTangentPlane ( R3 TWO nCells ) 0 o cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
@@ -162,7 +216,7 @@
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 - -
+var persistent real bottomDepth ( nCells ) 0 iro bottomDepth mesh - -
% Space needed for advection
var persistent real deriv_two ( maxEdges2 TWO nEdges ) 0 - deriv_two mesh - -
@@ -186,32 +240,32 @@
% Arrays required for reconstruction of velocity field
var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 - coeffs_reconstruct mesh - -
-% Arrays for z-level version of mpas-ocean
+% Arrays for non-isopycnal version of mpas-ocean
var persistent integer maxLevelCell ( nCells ) 0 iro maxLevelCell mesh - -
var persistent integer maxLevelEdgeTop ( nEdges ) 0 - maxLevelEdgeTop mesh - -
var persistent integer maxLevelEdgeBot ( nEdges ) 0 - maxLevelEdgeBot mesh - -
var persistent integer maxLevelVertexTop ( nVertices ) 0 - maxLevelVertexTop mesh - -
var persistent integer maxLevelVertexBot ( nVertices ) 0 - maxLevelVertexBot mesh - -
-var persistent real referenceBottomDepth ( nVertLevels ) 0 iro referenceBottomDepth mesh - -
-var persistent real referenceBottomDepthTopOfCell ( nVertLevelsP1 ) 0 - referenceBottomDepthTopOfCell mesh - -
+var persistent real refBottomDepth ( nVertLevels ) 0 iro refBottomDepth mesh - -
+var persistent real refBottomDepthTopOfCell ( nVertLevelsP1 ) 0 - refBottomDepthTopOfCell mesh - -
var persistent real hZLevel ( nVertLevels ) 0 iro hZLevel mesh - -
-var persistent real zstarWeight ( nVertLevels ) 0 - zstarWeight mesh - -
+var persistent real vertCoordMovementWeights ( nVertLevels ) 0 iro vertCoordMovementWeights mesh - -
-% Boundary conditions: read from input, saved in restart and written to output
-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 - -
+% Boundary conditions and masks
+var persistent integer boundaryEdge ( nVertLevels nEdges ) 0 - boundaryEdge mesh - -
+var persistent integer boundaryVertex ( nVertLevels nVertices ) 0 - boundaryVertex mesh - -
+var persistent integer boundaryCell ( nVertLevels nCells ) 0 - boundaryCell mesh - -
var persistent integer edgeMask ( nVertLevels nEdges ) 0 o edgeMask mesh - -
var persistent integer vertexMask ( nVertLevels nVertices ) 0 o vertexMask mesh - -
var persistent integer cellMask ( nVertLevels nCells ) 0 o cellMask mesh - -
-var persistent real u_src ( nVertLevels nEdges ) 0 iro u_src mesh - -
-var persistent real temperatureRestore ( nCells ) 0 iro temperatureRestore mesh - -
-var persistent real salinityRestore ( nCells ) 0 iro salinityRestore mesh - -
-% mrp trying to figure out why these do not appear
-var persistent real windStressMonthly ( nMonths nEdges ) 0 iro windStressMonthly mesh - -
-var persistent real temperatureRestoreMonthly ( nMonths nCells ) 0 iro temperatureRestoreMonthly mesh - -
-var persistent real salinityRestoreMonthly ( nMonths nCells ) 0 iro salinityRestoreMonthly mesh - -
+% Forcing variables.
+var persistent real u_src ( nVertLevels nEdges ) 0 ir u_src mesh - -
+var persistent real temperatureRestore ( nCells ) 0 ir temperatureRestore mesh - -
+var persistent real salinityRestore ( nCells ) 0 ir salinityRestore mesh - -
+var persistent real windStressMonthly ( nMonths nEdges ) 0 ir windStressMonthly mesh - -
+var persistent real temperatureRestoreMonthly ( nMonths nCells ) 0 ir temperatureRestoreMonthly mesh - -
+var persistent real salinityRestoreMonthly ( nMonths nCells ) 0 ir salinityRestoreMonthly mesh - -
% Prognostic variables: read from input, saved in restart, and written to output
var persistent real u ( nVertLevels nEdges Time ) 2 ir u state - -
@@ -230,7 +284,7 @@
var persistent real tend_tracer1 ( nVertLevels nCells Time ) 1 - tracer1 tend tracers testing
% state variables for Split Explicit timesplitting
-var persistent real uBtr ( nEdges Time ) 2 - uBtr state - -
+var persistent real uBtr ( nEdges Time ) 2 r uBtr state - -
var persistent real ssh ( nCells Time ) 2 o ssh state - -
var persistent real uBtrSubcycle ( nEdges Time ) 2 - uBtrSubcycle state - -
var persistent real sshSubcycle ( nCells Time ) 2 - sshSubcycle state - -
@@ -239,7 +293,7 @@
var persistent real uBcl ( nVertLevels nEdges Time ) 2 - uBcl state - -
% Diagnostic fields: only written to output
-var persistent real zMid ( nVertLevels nCells Time ) 2 io zMid state - -
+var persistent real zMid ( nVertLevels nCells Time ) 2 - zMid state - -
var persistent real v ( nVertLevels nEdges Time ) 2 - v state - -
var persistent real uTransport ( nVertLevels nEdges Time ) 2 - uTransport state - -
var persistent real uBolusGM ( nVertLevels nEdges Time ) 2 - uBolusGM state - -
@@ -275,7 +329,10 @@
var persistent real MontPot ( nVertLevels nCells Time ) 2 - MontPot state - -
var persistent real pressure ( nVertLevels nCells Time ) 2 - pressure state - -
var persistent real wTop ( nVertLevelsP1 nCells Time ) 2 - wTop state - -
+var persistent real vertVelocityTop ( nVertLevelsP1 nCells Time ) 2 - vertVelocityTop state - -
var persistent real rhoDisplaced ( nVertLevels nCells Time ) 2 - rhoDisplaced state - -
+var persistent real BruntVaisalaFreqTop ( nVertLevels nCells Time ) 2 o BruntVaisalaFreqTop state - -
+var persistent real viscosity ( nVertLevels nEdges Time ) 2 o viscosity state - -
% Other diagnostic variables: neither read nor written to any files
var persistent real vh ( nVertLevels nEdges Time ) 2 - vh state - -
@@ -307,3 +364,12 @@
var persistent real acc_uReconstructMeridionalVar ( nVertLevels nCells Time ) 2 o acc_uReconstructMeridionalVar state - -
var persistent real acc_u ( nVertLevels nEdges Time ) 2 o acc_u state - -
var persistent real acc_uVar ( nVertLevels nEdges Time ) 2 o acc_uVar state - -
+var persistent real acc_vertVelocityTop ( nVertLevelsP1 nCells Time ) 2 o acc_vertVelocityTop state - -
+
+% Sign fields, for openmp and bit reproducibility without branching statements.
+var persistent integer edgeSignOnCell ( maxEdges nCells ) 0 - edgeSignOnCell mesh - -
+var persistent integer edgeSignOnVertex ( maxEdges nVertices ) 0 - edgeSignOnVertex mesh - -
+var persistent integer kiteIndexOnCell ( maxEdges nCells ) 0 - kiteIndexOnCell mesh - -
+
+% Sea surface pressure, for coupling
+var persistent real seaSurfacePressure ( nCells Time ) 0 ir seaSurfacePressure mesh - -
Copied: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_diagnostics.F (from rev 2563, trunk/mpas/src/core_ocean/mpas_ocn_diagnostics.F)
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_diagnostics.F (rev 0)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_diagnostics.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -0,0 +1,848 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_diagnostics
+!
+!> \brief MPAS ocean diagnostics driver
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id:$
+!> \details
+!> This module contains the routines for computing
+!> diagnostic variables, and other quantities such as wTop.
+!
+!-----------------------------------------------------------------------
+
+module ocn_diagnostics
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_timer
+
+ use ocn_gm
+ use ocn_equation_of_state
+
+ implicit none
+ private
+ save
+
+ type (timer_node), pointer :: diagEOSTimer
+
+ !--------------------------------------------------------------------
+ !
+ ! Public parameters
+ !
+ !--------------------------------------------------------------------
+
+ !--------------------------------------------------------------------
+ !
+ ! Public member functions
+ !
+ !--------------------------------------------------------------------
+
+ public :: ocn_diagnostic_solve, &
+ ocn_wtop, &
+ ocn_fuperp, &
+ ocn_filter_btr_mode_u, &
+ ocn_filter_btr_mode_tend_u, &
+ ocn_diagnostics_init
+
+ !--------------------------------------------------------------------
+ !
+ ! Private module variables
+ !
+ !--------------------------------------------------------------------
+
+ integer :: ke_cell_flag, ke_vertex_flag
+ real (kind=RKIND) :: coef_3rd_order, fCoef
+
+!***********************************************************************
+
+contains
+
+!***********************************************************************
+!
+! routine ocn_diagnostic_solve
+!
+!> \brief Computes diagnostic variables
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the diagnostic variables for the ocean
+!
+!-----------------------------------------------------------------------
+
+ subroutine ocn_diagnostic_solve(dt, s, grid)!{{{
+ implicit none
+
+ real (kind=RKIND), intent(in) :: dt !< Input: Time step
+ type (state_type), intent(inout) :: s !< Input/Output: State information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
+ integer :: boundaryMask, velMask, nCells, nEdges, nVertices, nVertLevels, vertexDegree, err
+
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
+ maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
+ maxLevelVertexBot
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
+ verticesOnEdge, edgesOnEdge, edgesOnVertex,boundaryCell, kiteIndexOnCell, &
+ verticesOnCell, edgeSignOnVertex, edgeSignOnCell, edgesOnCell
+
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2, coef_3rd_order, r_tmp, &
+ invAreaCell1, invAreaCell2, invAreaTri1, invAreaTri2, invLength, h_vertex, coef
+
+ real (kind=RKIND), dimension(:), allocatable:: pTop, div_hu
+
+ real (kind=RKIND), dimension(:), pointer :: &
+ bottomDepth, fVertex, dvEdge, dcEdge, areaCell, areaTriangle, ssh, seaSurfacePressure
+ real (kind=RKIND), dimension(:,:), pointer :: &
+ weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure,&
+ circulation, vorticity, ke, ke_edge, MontPot, wTop, zMid, &
+ Vor_edge, Vor_vertex, Vor_cell, gradVor_n, gradVor_t, divergence, &
+ rho, rhoDisplaced, temperature, salinity, kev, kevc, uBolusGM, uTransport, &
+ vertVelocityTop, BruntVaisalaFreqTop
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers, deriv_two
+ character :: c1*6
+
+ h => s % h % array
+ u => s % u % array
+ uTransport => s % uTransport % array
+ uBolusGM => s % uBolusGM % array
+ v => s % v % array
+ h_edge => s % h_edge % array
+ circulation => s % circulation % array
+ vorticity => s % vorticity % array
+ divergence => s % divergence % array
+ ke => s % ke % array
+ kev => s % kev % array
+ kevc => s % kevc % array
+ ke_edge => s % ke_edge % array
+ Vor_edge => s % Vor_edge % array
+ Vor_vertex => s % Vor_vertex % array
+ Vor_cell => s % Vor_cell % array
+ gradVor_n => s % gradVor_n % array
+ gradVor_t => s % gradVor_t % array
+ rho => s % rho % array
+ rhoDisplaced=> s % rhoDisplaced % array
+ MontPot => s % MontPot % array
+ pressure => s % pressure % array
+ zMid => s % zMid % array
+ ssh => s % ssh % array
+ tracers => s % tracers % array
+ vertVelocityTop => s % vertVelocityTop % array
+ BruntVaisalaFreqTop => s % BruntVaisalaFreqTop % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnVertex => grid % cellsOnVertex % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ bottomDepth => grid % bottomDepth % array
+ fVertex => grid % fVertex % array
+ deriv_two => grid % deriv_two % array
+ maxLevelCell => grid % maxLevelCell % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ maxLevelEdgeBot => grid % maxLevelEdgeBot % array
+ maxLevelVertexBot => grid % maxLevelVertexBot % array
+ kiteIndexOnCell => grid % kiteIndexOnCell % array
+ verticesOnCell => grid % verticesOnCell % array
+
+ seaSurfacePressure => grid % seaSurfacePressure % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+ vertexDegree = grid % vertexDegree
+
+ boundaryCell => grid % boundaryCell % array
+
+ edgeSignOnVertex => grid % edgeSignOnVertex % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
+
+ !
+ ! Compute height on cell edges at velocity locations
+ ! Namelist options control the order of accuracy of the reconstructed h_edge value
+ !
+ ! mrp 101115 note: in order to include flux boundary conditions, we will need to
+ ! assign h_edge for maxLevelEdgeTop:maxLevelEdgeBot in the following section
+
+ ! initialize h_edge to avoid divide by zero and NaN problems.
+ h_edge = -1.0e34
+ coef_3rd_order = config_coef_3rd_order
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,maxLevelEdgeTop(iEdge)
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
+ end do
+
+ !
+ ! set the velocity and height at dummy address
+ ! used -1e34 so error clearly occurs if these values are used.
+ !
+ u(:,nEdges+1) = -1e34
+ h(:,nCells+1) = -1e34
+ tracers(s % index_temperature,:,nCells+1) = -1e34
+ tracers(s % index_salinity,:,nCells+1) = -1e34
+
+ circulation(:,:) = 0.0
+ vorticity(:,:) = 0.0
+ divergence(:,:) = 0.0
+ vertVelocityTop(:,:)=0.0
+ ke(:,:) = 0.0
+ v(:,:) = 0.0
+ do iVertex = 1, nVertices
+ invAreaTri1 = 1.0 / areaTriangle(iVertex)
+ do i = 1, vertexDegree
+ iEdge = edgesOnVertex(i, iVertex)
+ do k = 1, maxLevelVertexBot(iVertex)
+ r_tmp = dcEdge(iEdge) * u(k, iEdge)
+
+ circulation(k, iVertex) = circulation(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp
+ vorticity(k, iVertex) = vorticity(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp * invAreaTri1
+ end do
+ end do
+ end do
+
+ allocate(div_hu(nVertLevels))
+ do iCell = 1, nCells
+ div_hu(:) = 0.0
+ invAreaCell1 = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+ do k = 1, maxLevelCell(iCell)
+ r_tmp = dvEdge(iEdge) * u(k, iEdge) * invAreaCell1
+
+ divergence(k, iCell) = divergence(k, iCell) - edgeSignOnCell(i, iCell) * r_tmp
+ div_hu(k) = div_hu(k) - h_edge(k, iEdge) * edgeSignOnCell(i, iCell) * r_tmp
+ ke(k, iCell) = ke(k, iCell) + 0.25 * r_tmp * dcEdge(iEdge) * u(k,iEdge)
+ end do
+ end do
+ ! Vertical velocity at bottom (maxLevelCell(iCell)+1) is zero, initialized above.
+ do k=maxLevelCell(iCell),1,-1
+ vertVelocityTop(k,iCell) = vertVelocityTop(k+1,iCell) - div_hu(k)
+ end do
+ end do
+ deallocate(div_hu)
+
+ do iEdge=1,nEdges
+ ! Compute v (tangential) velocities
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ ! mrp 101115 note: in order to include flux boundary conditions,
+ ! the following loop may need to change to maxLevelEdgeBot
+ do k = 1,maxLevelEdgeTop(iEdge)
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
+ end do
+
+ end do
+
+ !
+ ! Compute kinetic energy in each vertex
+ !
+ kev(:,:) = 0.0; kevc(:,:) = 0.0
+ do iVertex = 1, nVertices*ke_vertex_flag
+ do i = 1, vertexDegree
+ iEdge = edgesOnVertex(i, iVertex)
+ r_tmp = dcEdge(iEdge) * dvEdge(iEdge) * 0.25 / areaTriangle(iVertex)
+ do k = 1, nVertLevels
+ kev(k, iVertex) = kev(k, iVertex) + r_tmp * u(k, iEdge)**2
+ end do
+ end do
+ end do
+
+ do iCell = 1, nCells*ke_vertex_flag
+ invAreaCell1 = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ j = kiteIndexOnCell(i, iCell)
+ iVertex = verticesOnCell(i, iCell)
+ do k = 1, nVertLevels
+ kevc(k, iCell) = kevc(k, iCell) + kiteAreasOnVertex(j, iVertex) * kev(k, iVertex) * invAreaCell1
+ end do
+ end do
+ end do
+
+ !
+ ! Compute kinetic energy in each cell by blending ke and kevc
+ !
+ do iCell=1,nCells*ke_vertex_flag
+ do k=1,nVertLevels
+ ke(k,iCell) = 5.0/8.0*ke(k,iCell) + 3.0/8.0*kevc(k,iCell)
+ end do
+ end do
+
+ !
+ ! Compute ke on cell edges at velocity locations for quadratic bottom drag.
+ !
+ ! mrp 101025 efficiency note: we could get rid of ke_edge completely by
+ ! using sqrt(u(k,iEdge)**2 + v(k,iEdge)**2) in its place elsewhere.
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,maxLevelEdgeTop(iEdge)
+ ke_edge(k,iEdge) = 0.5 * (ke(k,cell1) + ke(k,cell2))
+ end do
+ end do
+
+ !
+ ! Compute height at vertices, pv at vertices, and average pv to edge locations
+ ! ( this computes Vor_vertex at all vertices bounding real cells and distance-1 ghost cells )
+ !
+ do iVertex = 1,nVertices
+ invAreaTri1 = 1.0 / areaTriangle(iVertex)
+ do k=1,maxLevelVertexBot(iVertex)
+ h_vertex = 0.0
+ do i=1,vertexDegree
+ h_vertex = h_vertex + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
+ end do
+ h_vertex = h_vertex * invAreaTri1
+
+ Vor_vertex(k,iVertex) = (fCoef*fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
+ end do
+ end do
+
+ Vor_cell(:,:) = 0.0
+ Vor_edge(:,:) = 0.0
+ do iEdge = 1, nEdges
+ vertex1 = verticesOnEdge(1, iEdge)
+ vertex2 = verticesOnEdge(2, iEdge)
+ do k = 1, maxLevelEdgeBot(iEdge)
+ Vor_edge(k, iEdge) = 0.5 * (Vor_vertex(k, vertex1) + Vor_vertex(k, vertex2))
+ end do
+ end do
+
+ do iCell = 1, nCells
+ invAreaCell1 = 1.0 / areaCell(iCell)
+
+ do i = 1, nEdgesOnCell(iCell)
+ j = kiteIndexOnCell(i, iCell)
+ iVertex = verticesOnCell(i, iCell)
+ do k = 1, maxLevelCell(iCell)
+ Vor_cell(k, iCell) = Vor_cell(k, iCell) + kiteAreasOnVertex(j, iVertex) * Vor_vertex(k, iVertex) * invAreaCell1
+ end do
+ end do
+ end do
+
+ do iEdge = 1,nEdges
+ cell1 = cellsOnEdge(1, iEdge)
+ cell2 = cellsOnEdge(2, iEdge)
+ vertex1 = verticesOnedge(1, iEdge)
+ vertex2 = verticesOnedge(2, iEdge)
+
+ invLength = 1.0 / dcEdge(iEdge)
+ ! Compute gradient of PV in normal direction
+ ! ( this computes gradVor_n for all edges bounding real cells )
+ do k=1,maxLevelEdgeTop(iEdge)
+ gradVor_n(k,iEdge) = (Vor_cell(k,cell2) - Vor_cell(k,cell1)) * invLength
+ enddo
+
+ invLength = 1.0 / dvEdge(iEdge)
+ ! Compute gradient of PV in the tangent direction
+ ! ( this computes gradVor_t at all edges bounding real cells and distance-1 ghost cells )
+ do k = 1,maxLevelEdgeBot(iEdge)
+ gradVor_t(k,iEdge) = (Vor_vertex(k,vertex2) - Vor_vertex(k,vertex1)) * invLength
+ enddo
+
+ enddo
+
+ !
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,maxLevelEdgeBot(iEdge)
+ Vor_edge(k,iEdge) = Vor_edge(k,iEdge) &
+ - config_apvm_scale_factor * dt* ( u(k,iEdge) * gradVor_n(k,iEdge) &
+ + v(k,iEdge) * gradVor_t(k,iEdge) )
+ enddo
+ enddo
+
+ !
+ ! equation of state
+ !
+ ! For an isopycnal model, density should remain constant.
+ ! For zlevel, calculate in-situ density
+ if (config_vert_coord_movement.ne.'isopycnal') then
+ call mpas_timer_start("equation of state", .false., diagEOSTimer)
+
+ ! compute in-place density
+ call ocn_equation_of_state_rho(s, grid, 0, 'relative', err)
+
+ ! compute rhoDisplaced, the potential density referenced to the top layer
+ call ocn_equation_of_state_rho(s, grid, 1, 'relative', err)
+
+ call mpas_timer_stop("equation of state", diagEOSTimer)
+ endif
+
+ !
+ ! Pressure
+ ! This section must be after computing rho
+ !
+ ! dwj: 10/25/2011 - Need to explore isopycnal vs zlevel flags
+ if (config_pressure_gradient_type.eq.'MontgomeryPotential') then
+
+ ! For Isopycnal model.
+ ! Compute pressure at top of each layer, and then
+ ! Montgomery Potential.
+ allocate(pTop(nVertLevels))
+ do iCell=1,nCells
+
+ ! assume atmospheric pressure at the surface is zero for now.
+ pTop(1) = 0.0
+ ! For isopycnal mode, p is the Montgomery Potential.
+ ! At top layer it is g*SSH, where SSH may be off by a
+ ! constant (ie, bottomDepth can be relative to top or bottom)
+ MontPot(1,iCell) = gravity &
+ * (bottomDepth(iCell) + sum(h(1:nVertLevels,iCell)))
+
+ do k=2,nVertLevels
+ pTop(k) = pTop(k-1) + rho(k-1,iCell)*gravity* h(k-1,iCell)
+
+ ! from delta M = p delta / rho
+ MontPot(k,iCell) = MontPot(k-1,iCell) &
+ + pTop(k)*(1.0/rho(k,iCell) - 1.0/rho(k-1,iCell))
+ end do
+
+ end do
+ deallocate(pTop)
+
+ else
+
+ do iCell=1,nCells
+ ! Pressure for generalized coordinates.
+ ! Pressure at top surface may be due to atmospheric pressure
+ ! or an ice-shelf depression.
+ pressure(1,iCell) = seaSurfacePressure(iCell) + rho(1,iCell)*gravity &
+ * 0.5*h(1,iCell)
+
+ do k=2,maxLevelCell(iCell)
+ pressure(k,iCell) = pressure(k-1,iCell) &
+ + 0.5*gravity*( rho(k-1,iCell)*h(k-1,iCell) &
+ + rho(k ,iCell)*h(k ,iCell))
+ end do
+
+ ! Compute zMid, the z-coordinate of the middle of the layer.
+ ! This is used for the rho g grad z momentum term.
+ ! Note the negative sign, since bottomDepth is positive
+ ! and z-coordinates are negative below the surface.
+ k = maxLevelCell(iCell)
+ zMid(k:nVertLevels,iCell) = -bottomDepth(iCell) + 0.5*h(k,iCell)
+
+ do k=maxLevelCell(iCell)-1, 1, -1
+ zMid(k,iCell) = zMid(k+1,iCell) &
+ + 0.5*( h(k+1,iCell) &
+ + h(k ,iCell))
+ end do
+
+ end do
+
+ endif
+
+ !
+ ! Brunt-Vaisala frequency
+ !
+ coef = -gravity/config_rho0
+ do iCell=1,nCells
+ BruntVaisalaFreqTop(1,iCell) = 0.0
+ do k=2,maxLevelCell(iCell)
+ BruntVaisalaFreqTop(k,iCell) = coef * (rhoDisplaced(k-1,iCell) - rhoDisplaced(k,iCell)) &
+ / (zMid(k-1,iCell) - zMid(k,iCell))
+ end do
+ end do
+
+ !
+ ! Sea Surface Height
+ !
+ do iCell=1,nCells
+ ! Start at the bottom where we know the depth, and go up.
+ ! The bottom depth for this cell is bottomDepth(iCell).
+ ! Note the negative sign, since bottomDepth is positive
+ ! and z-coordinates are negative below the surface.
+
+ ssh(iCell) = - bottomDepth(iCell) + sum(h(1:maxLevelCell(iCell),iCell))
+
+ end do
+
+ !
+ ! Apply the GM closure as a bolus velocity
+ !
+ if (config_h_kappa .GE. epsilon(0D0)) then
+ call ocn_gm_compute_uBolus(s,grid)
+ else
+ ! mrp efficiency note: if uBolusGM is guaranteed to be zero, this can be removed.
+ uBolusGM = 0.0
+ end if
+
+ end subroutine ocn_diagnostic_solve!}}}
+
+!***********************************************************************
+!
+! routine ocn_wtop
+!
+!> \brief Computes vertical transport
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the vertical transport through the top of each
+!> cell.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_wtop(grid,h,h_edge,u,wTop, err)!{{{
+
+ !-----------------------------------------------------------------
+ !
+ ! input variables
+ !
+ !-----------------------------------------------------------------
+
+ type (mesh_type), intent(in) :: &
+ grid !< Input: grid information
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h !< Input: thickness
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h_edge !< Input: h interpolated to an edge
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ u !< Input: transport
+
+ !-----------------------------------------------------------------
+ !
+ ! output variables
+ !
+ !-----------------------------------------------------------------
+
+ real (kind=RKIND), dimension(:,:), intent(out) :: &
+ wTop !< Output: vertical transport at top of cell
+
+ integer, intent(out) :: err !< Output: error flag
+
+ !-----------------------------------------------------------------
+ !
+ ! local variables
+ !
+ !-----------------------------------------------------------------
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, rho0Inv, hSum, invAreaCell
+
+ integer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree
+
+
+ real (kind=RKIND), dimension(:), pointer :: &
+ dvEdge, areaCell, vertCoordMovementWeights
+ real (kind=RKIND), dimension(:), allocatable:: div_hu, h_tend_col
+ real (kind=RKIND) :: div_hu_btr
+
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
+ verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, &
+ boundaryEdge, boundaryCell, edgeSignOnCell
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
+ maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
+ maxLevelVertexBot, maxLevelVertexTop
+
+ err = 0
+
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ areaCell => grid % areaCell % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
+ maxLevelCell => grid % maxLevelCell % array
+ maxLevelEdgeBot => grid % maxLevelEdgeBot % array
+ dvEdge => grid % dvEdge % array
+ vertCoordMovementWeights => grid % vertCoordMovementWeights % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+
+
+ if (config_vert_coord_movement.eq.'isopycnal') then
+ ! set vertical transport to zero in isopycnal case
+ wTop=0.0
+ return
+ end if
+
+ allocate(div_hu(nVertLevels), h_tend_col(nVertLevels))
+
+ !
+ ! Compute div(h^{edge} u) for each cell
+ ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
+ !
+
+ do iCell=1,nCells
+ div_hu(:) = 0.0
+ div_hu_btr = 0.0
+ hSum = 0.0
+ invAreaCell = 1.0 / areaCell(iCell)
+
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+
+ do k = 1, maxLevelEdgeBot(iEdge)
+ flux = h_edge(k, iEdge) * u(k, iEdge) * dvEdge(iEdge) * edgeSignOnCell(i, iCell) * invAreaCell
+ div_hu(k) = div_hu(k) - flux
+ div_hu_btr = div_hu_btr - flux
+ end do
+ end do
+
+ do k = 1, maxLevelCell(iCell)
+ h_tend_col(k) = - vertCoordMovementWeights(k) * h(k, iCell) * div_hu_btr
+ hSum = hSum + vertCoordMovementWeights(k) * h(k, iCell)
+ end do
+
+ if(hSum > 0.0) then
+ h_tend_col = h_tend_col / hSum
+ end if
+
+ ! Vertical transport through layer interface at top and bottom is zero.
+ wTop(1,iCell) = 0.0
+ wTop(maxLevelCell(iCell)+1,iCell) = 0.0
+ do k=maxLevelCell(iCell),2,-1
+ wTop(k,iCell) = wTop(k+1,iCell) - div_hu(k) - h_tend_col(k)
+ end do
+ end do
+
+ deallocate(div_hu, h_tend_col)
+
+ end subroutine ocn_wtop!}}}
+
+!***********************************************************************
+!
+! routine ocn_fuperp
+!
+!> \brief Computes f u_perp
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine computes f u_perp for the ocean
+!
+!-----------------------------------------------------------------------
+
+ subroutine ocn_fuperp(s, grid)!{{{
+ implicit none
+
+ type (state_type), intent(inout) :: s !< Input/Output: State information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+! mrp 110512 I just split compute_tend into compute_tend_u and compute_tend_h.
+! Some of these variables can be removed, but at a later time.
+ integer :: iEdge, cell1, cell2, eoe, i, j, k
+
+ integer :: nEdgesSolve
+ real (kind=RKIND), dimension(:), pointer :: fEdge
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, u, uBcl
+ type (dm_info) :: dminfo
+
+ integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge
+
+ call mpas_timer_start("ocn_fuperp")
+
+ u => s % u % array
+ uBcl => s % uBcl % array
+ weightsOnEdge => grid % weightsOnEdge % array
+ fEdge => grid % fEdge % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+
+ fEdge => grid % fEdge % array
+
+ nEdgesSolve = grid % nEdgesSolve
+
+ !
+ ! Put f*uBcl^{perp} in u as a work variable
+ !
+ do iEdge=1,nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,maxLevelEdgeTop(iEdge)
+
+ u(k,iEdge) = 0.0
+ do j = 1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ u(k,iEdge) = u(k,iEdge) + weightsOnEdge(j,iEdge) * uBcl(k,eoe) * fEdge(eoe)
+ end do
+ end do
+ end do
+
+ call mpas_timer_stop("ocn_fuperp")
+
+ end subroutine ocn_fuperp!}}}
+
+!***********************************************************************
+!
+! routine ocn_filter_btr_mode_u
+!
+!> \brief filters barotropic mode out of the velocity variable.
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine filters barotropic mode out of the velocity variable.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_filter_btr_mode_u(s, grid)!{{{
+ implicit none
+
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iEdge, k, nEdges
+ real (kind=RKIND) :: vertSum, uhSum, hSum
+ real (kind=RKIND), dimension(:,:), pointer :: h_edge, u
+ integer, dimension(:), pointer :: maxLevelEdgeTop
+
+ call mpas_timer_start("ocn_filter_btr_mode_u")
+
+ u => s % u % array
+ h_edge => s % h_edge % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ nEdges = grid % nEdges
+
+ do iEdge=1,nEdges
+
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ uhSum = h_edge(1,iEdge) * u(1,iEdge)
+ hSum = h_edge(1,iEdge)
+
+ do k=2,maxLevelEdgeTop(iEdge)
+ uhSum = uhSum + h_edge(k,iEdge) * u(k,iEdge)
+ hSum = hSum + h_edge(k,iEdge)
+ enddo
+
+ vertSum = uhSum/hSum
+ do k=1,maxLevelEdgeTop(iEdge)
+ u(k,iEdge) = u(k,iEdge) - vertSum
+ enddo
+ enddo ! iEdge
+
+ call mpas_timer_stop("ocn_filter_btr_mode_u")
+
+ end subroutine ocn_filter_btr_mode_u!}}}
+
+!***********************************************************************
+!
+! routine ocn_filter_btr_mode_tend_u
+!
+!> \brief ocn_filters barotropic mode out of the u tendency
+!> \author Mark Petersen
+!> \date 23 September 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine filters barotropic mode out of the u tendency.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_filter_btr_mode_tend_u(tend, s, grid)!{{{
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iEdge, k, nEdges
+ real (kind=RKIND) :: vertSum, uhSum, hSum
+ real (kind=RKIND), dimension(:,:), pointer :: h_edge, tend_u
+
+ integer, dimension(:), pointer :: maxLevelEdgeTop
+
+ call mpas_timer_start("ocn_filter_btr_mode_tend_u")
+
+ tend_u => tend % u % array
+ h_edge => s % h_edge % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ nEdges = grid % nEdges
+
+ do iEdge=1,nEdges
+
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ uhSum = h_edge(1,iEdge) * tend_u(1,iEdge)
+ hSum = h_edge(1,iEdge)
+
+ do k=2,maxLevelEdgeTop(iEdge)
+ uhSum = uhSum + h_edge(k,iEdge) * tend_u(k,iEdge)
+ hSum = hSum + h_edge(k,iEdge)
+ enddo
+
+ vertSum = uhSum/hSum
+ do k=1,maxLevelEdgeTop(iEdge)
+ tend_u(k,iEdge) = tend_u(k,iEdge) - vertSum
+ enddo
+ enddo ! iEdge
+
+ call mpas_timer_stop("ocn_filter_btr_mode_tend_u")
+
+ end subroutine ocn_filter_btr_mode_tend_u!}}}
+
+!***********************************************************************
+!
+! routine ocn_diagnostics_init
+!
+!> \brief Initializes flags used within diagnostics routines.
+!> \author Mark Petersen
+!> \date 4 November 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine initializes flags related to quantities computed within
+!> other diagnostics routines.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_diagnostics_init(err)!{{{
+ integer, intent(out) :: err !< Output: Error flag
+
+ err = 0
+
+ if(config_include_KE_vertex) then
+ ke_vertex_flag = 1
+ ke_cell_flag = 0
+ else
+ ke_vertex_flag = 0
+ ke_cell_flag = 1
+ endif
+
+ if (trim(config_time_integrator) == 'RK4') then
+ ! for RK4, PV is really PV = (eta+f)/h
+ fCoef = 1
+ elseif (trim(config_time_integrator) == 'split_explicit' &
+ .or.trim(config_time_integrator) == 'unsplit_explicit') then
+ ! for split explicit, PV is eta/h because f is added separately to the momentum forcing.
+ ! mrp temp, new should be:
+ fCoef = 0
+ ! old, for testing:
+ ! fCoef = 1
+ end if
+
+ end subroutine ocn_diagnostics_init!}}}
+
+!***********************************************************************
+
+end module ocn_diagnostics
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+! vim: foldmethod=marker
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -158,7 +158,7 @@
linearEos = .false.
jmEos = .false.
- if(config_vert_grid_type.ne.'isopycnal') then
+ if(config_vert_coord_movement.ne.'isopycnal') then
eosON = .true.
if (config_eos_type.eq.'linear') then
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state_jm.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state_jm.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state_jm.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -96,7 +96,7 @@
real (kind=RKIND), dimension(:), pointer :: &
- referenceBottomDepth, pRefEOS
+ refBottomDepth, pRefEOS
real (kind=RKIND), dimension(:,:), intent(inout) :: &
rho
real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers
@@ -197,7 +197,7 @@
nCells = grid % nCells
maxLevelCell => grid % maxLevelCell % array
nVertLevels = grid % nVertLevels
- referenceBottomDepth => grid % referenceBottomDepth % array
+ refBottomDepth => grid % refBottomDepth % array
! Jackett and McDougall
@@ -214,14 +214,14 @@
allocate(pRefEOS(nVertLevels),p(nVertLevels),p2(nVertLevels))
! This could be put in the init routine.
- ! Note I am using referenceBottomDepth, so pressure on top level does
+ ! Note I am using refBottomDepth, so pressure on top level does
! not include SSH contribution. I am not sure if that matters, but
! POP does it the same way.
- depth = 0.5*referenceBottomDepth(1)
+ depth = 0.5*refBottomDepth(1)
pRefEOS(1) = 0.059808*(exp(-0.025*depth) - 1.0) &
+ 0.100766*depth + 2.28405e-7*depth**2
do k = 2,nVertLevels
- depth = 0.5*(referenceBottomDepth(k)+referenceBottomDepth(k-1))
+ depth = 0.5*(refBottomDepth(k)+refBottomDepth(k-1))
pRefEOS(k) = 0.059808*(exp(-0.025*depth) - 1.0) &
+ 0.100766*depth + 2.28405e-7*depth**2
enddo
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state_linear.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state_linear.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_equation_of_state_linear.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -82,27 +82,21 @@
integer, intent(in) :: indexT, indexS
integer, intent(out) :: err
- real (kind=RKIND), parameter :: rho_ref = 1025.022 ! kg / m^3
- real (kind=RKIND), parameter :: alpha = 2.55e-1 ! kg / m^3 / K (dT/dRho)
- real (kind=RKIND), parameter :: beta = 7.64e-1 ! kg / m^3 / psu (dS/dRho)
- real (kind=RKIND), parameter :: T_ref = 19.0 ! K
- real (kind=RKIND), parameter :: S_ref = 35.0 ! psu
- real (kind=RKIND), parameter :: rho_prime_ref = rho_ref + alpha * T_ref - beta * S_ref
-
integer, dimension(:), pointer :: maxLevelCell
integer :: nCells, iCell, k
type (dm_info) :: dminfo
- maxLevelCell => grid % maxLevelCell % array
- nCells = grid % nCells
+ maxLevelCell => grid % maxLevelCell % array
+ nCells = grid % nCells
err = 0
do iCell=1,nCells
do k=1,maxLevelCell(iCell)
! Linear equation of state
- ! rho = rho_ref - alpha * (T - T_ref) + beta * (S - S_ref)
- rho(k,iCell) = rho_prime_ref - alpha*tracers(indexT,k,iCell) + beta*tracers(indexS,k,iCell)
+ rho(k,iCell) = config_eos_linear_rhoref &
+ - config_eos_linear_alpha * (tracers(indexT,k,iCell)-config_eos_linear_Tref) &
+ + config_eos_linear_beta * (tracers(indexS,k,iCell)-config_eos_linear_Sref)
end do
end do
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_global_diagnostics.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_global_diagnostics.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_global_diagnostics.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -421,27 +421,27 @@
! write out the data to files
if (dminfo % my_proc_id == IO_NODE) then
fileID = getFreeUnit()
- open(fileID,file='stats_min.txt',ACCESS='append')
+ open(fileID,file='stats_min.txt',STATUS='UNKNOWN', POSITION='append')
write (fileID,'(100es24.14)') mins(1:nVariables)
close (fileID)
- open(fileID,file='stats_max.txt',ACCESS='append')
+ open(fileID,file='stats_max.txt',STATUS='UNKNOWN', POSITION='append')
write (fileID,'(100es24.14)') maxes(1:nVariables)
close (fileID)
- open(fileID,file='stats_sum.txt',ACCESS='append')
+ open(fileID,file='stats_sum.txt',STATUS='UNKNOWN', POSITION='append')
write (fileID,'(100es24.14)') sums(1:nVariables)
close (fileID)
- open(fileID,file='stats_avg.txt',ACCESS='append')
+ open(fileID,file='stats_avg.txt',STATUS='UNKNOWN', POSITION='append')
write (fileID,'(100es24.14)') averages(1:nVariables)
close (fileID)
- open(fileID,file='stats_time.txt',ACCESS='append')
+ open(fileID,file='stats_time.txt',STATUS='UNKNOWN', POSITION='append')
write (fileID,'(i10,10x,a,100es24.14)') timeIndex, &
state % xtime % scalar, dt, &
CFLNumberGlobal
close (fileID)
- open(fileID,file='stats_colmin.txt',ACCESS='append')
+ open(fileID,file='stats_colmin.txt',STATUS='UNKNOWN', POSITION='append')
write (fileID,'(100es24.14)') verticalSumMins(1:nVariables)
close (fileID)
- open(fileID,file='stats_colmax.txt',ACCESS='append')
+ open(fileID,file='stats_colmax.txt',STATUS='UNKNOWN', POSITION='append')
write (fileID,'(100es24.14)') verticalSumMaxes(1:nVariables)
close (fileID)
end if
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_gm.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_gm.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_gm.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -30,7 +30,7 @@
contains
- subroutine ocn_gm_compute_uBolus(s, grid)
+ subroutine ocn_gm_compute_uBolus(s, grid)!{{{
implicit none
type(state_type), intent(inout) :: s
type(mesh_type), intent(in) :: grid
@@ -50,7 +50,7 @@
call ocn_gm_compute_hEddyFlux(s, grid)
- if (config_vert_grid_type .EQ. 'isopycnal') then
+ if (config_vert_coord_movement .EQ. 'isopycnal') then
do iEdge = 1, nEdges
do k = 1, maxLevelEdgeTop(iEdge)
@@ -65,10 +65,9 @@
end if
- end subroutine ocn_gm_compute_uBolus
+ end subroutine ocn_gm_compute_uBolus!}}}
-
- subroutine ocn_gm_compute_hEddyFlux(s, grid)
+ subroutine ocn_gm_compute_hEddyFlux(s, grid)!{{{
implicit none
type(state_type), intent(inout) :: s
type(mesh_type), intent(in) :: grid
@@ -90,7 +89,7 @@
hEddyFlux(:,:) = 0.0
- if (config_vert_grid_type .EQ. 'isopycnal') then
+ if (config_vert_coord_movement .EQ. 'isopycnal') then
do iEdge = 1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
@@ -104,12 +103,10 @@
end if
- end subroutine ocn_gm_compute_hEddyFlux
+ end subroutine ocn_gm_compute_hEddyFlux!}}}
+ subroutine ocn_get_h_kappa(s, grid)!{{{
-
- subroutine ocn_get_h_kappa(s, grid)
-
type (state_type), intent(inout) :: s
type (mesh_type), intent(in) :: grid
@@ -121,11 +118,10 @@
h_kappa(:,:) = config_h_kappa
- end subroutine ocn_get_h_kappa
+ end subroutine ocn_get_h_kappa!}}}
+ subroutine ocn_get_h_kappa_q(s, grid)!{{{
- subroutine ocn_get_h_kappa_q(s, grid)
-
type (state_type), intent(inout) :: s
type (mesh_type), intent(in) :: grid
@@ -137,6 +133,6 @@
h_kappa_q(:,:) = config_h_kappa_q
- end subroutine ocn_get_h_kappa_q
+ end subroutine ocn_get_h_kappa_q!}}}
end module ocn_gm
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_monthly_forcing.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_monthly_forcing.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_monthly_forcing.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -176,6 +176,8 @@
if(config_use_monthly_forcing) then
monthlyForcingOn = .true.
+
+ write (0,'(a)') " Monthly forcing is on. Make sure monthly forcing variables include iro in Registry, and are in your initial condition or restart file."
end if
!--------------------------------------------------------------------
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_mpas_core.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_mpas_core.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_mpas_core.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -6,20 +6,24 @@
use mpas_dmpar
use mpas_timer
+ use ocn_tracer_advection
+
use ocn_global_diagnostics
- use ocn_test_cases
use ocn_time_integration
use ocn_tendency
+ use ocn_diagnostics
use ocn_monthly_forcing
+ use ocn_thick_hadv
+ use ocn_thick_vadv
+
use ocn_vel_pressure_grad
use ocn_vel_vadv
use ocn_vel_hmix
use ocn_vel_forcing
+ use ocn_vel_coriolis
- use ocn_tracer_hadv
- use ocn_tracer_vadv
use ocn_tracer_hmix
use ocn_gm
use ocn_restoring
@@ -48,7 +52,6 @@
subroutine mpas_core_init(domain, startTimeStamp)!{{{
use mpas_grid_types
- use mpas_ocn_tracer_advection
implicit none
@@ -64,9 +67,16 @@
! Initialize submodules before initializing blocks.
call ocn_timestep_init(err)
+ call ocn_thick_hadv_init(err_tmp)
+ err = ior(err, err_tmp)
+
+ call ocn_thick_vadv_init(err_tmp)
+ err = ior(err, err_tmp)
+
+ call ocn_vel_coriolis_init(err_tmp)
+ err = ior(err, err_tmp)
call ocn_vel_pressure_grad_init(err_tmp)
err = ior(err, err_tmp)
-
call ocn_vel_vadv_init(err_tmp)
err = ior(err, err_tmp)
call ocn_vel_hmix_init(err_tmp)
@@ -74,10 +84,6 @@
call ocn_vel_forcing_init(err_tmp)
err = ior(err, err_tmp)
- call ocn_tracer_hadv_init(err_tmp)
- err = ior(err, err_tmp)
- call ocn_tracer_vadv_init(err_tmp)
- err = ior(err, err_tmp)
call ocn_tracer_hmix_init(err_tmp)
err = ior(err, err_tmp)
call ocn_restoring_init(err_tmp)
@@ -91,8 +97,10 @@
call ocn_tendency_init(err_tmp)
err = ior(err,err_tmp)
+ call ocn_diagnostics_init(err_tmp)
+ err = ior(err,err_tmp)
- call mpas_ocn_tracer_advection_init(err_tmp)
+ call ocn_tracer_advection_init(err_tmp)
err = ior(err,err_tmp)
call ocn_monthly_forcing_init(err_tmp)
@@ -104,40 +112,38 @@
call mpas_dmpar_abort(dminfo)
endif
- if (.not. config_do_restart) call setup_sw_test_case(domain)
+ if (config_vert_coord_movement.ne.'isopycnal') call ocn_init_vert_coord(domain)
call ocn_compute_max_level(domain)
- call ocn_init_z_level(domain)
+ if (.not.config_do_restart) call ocn_init_split_timestep(domain)
- if (config_enforce_zstar_at_restart) then
- call ocn_init_h_zstar(domain)
- endif
+ write (0,'(a,a)') ' Vertical coordinate movement is: ',trim(config_vert_coord_movement)
- call ocn_init_split_timestep(domain)
-
- print *, ' Vertical grid type is: ',config_vert_grid_type
-
- if (config_vert_grid_type.ne.'isopycnal'.and. &
- config_vert_grid_type.ne.'zlevel'.and. &
- config_vert_grid_type.ne.'zstar1'.and. &
- config_vert_grid_type.ne.'zstar'.and. &
- config_vert_grid_type.ne.'zstarWeights') then
- print *, ' Incorrect choice of config_vert_grid_type.'
+ if (config_vert_coord_movement.ne.'isopycnal'.and. &
+ config_vert_coord_movement.ne.'fixed'.and. &
+ config_vert_coord_movement.ne.'uniform_stretching'.and. &
+ config_vert_coord_movement.ne.'user_specified') then
+ write (0,*) ' Incorrect choice of config_vert_coord_movement.'
call mpas_dmpar_abort(dminfo)
endif
- print *, ' Pressure type is: ',config_pressure_type
- if (config_pressure_type.ne.'pressure'.and. &
- config_pressure_type.ne.'MontgomeryPotential') then
- print *, ' Incorrect choice of config_pressure_type.'
+ write (0,'(a,a)') ' Pressure type is: ',trim(config_pressure_gradient_type)
+ if (config_pressure_gradient_type.ne.'pressure_and_zmid'.and. &
+ config_pressure_gradient_type.ne.'MontgomeryPotential') then
+ write (0,*) ' Incorrect choice of config_pressure_gradient_type.'
call mpas_dmpar_abort(dminfo)
endif
+ if(config_vert_coord_movement .ne. 'isopycnal' .and. config_pressure_gradient_type .eq. 'MontgomeryPotential') then
+ write (0,*) ' Incorrect combination of config_vert_coord_movement and config_pressure_gradient_type'
+ call mpas_dmpar_abort(dminfo)
+ end if
+
if (config_filter_btr_mode.and. &
- config_vert_grid_type.ne.'zlevel')then
- print *, 'filter_btr_mode has only been tested with'// &
- ' config_vert_grid_type=zlevel.'
+ config_vert_coord_movement.ne.'fixed')then
+ write (0,*) 'filter_btr_mode has only been tested with'// &
+ ' config_vert_coord_movement=fixed.'
call mpas_dmpar_abort(dminfo)
endif
@@ -162,7 +168,7 @@
! input arguement into mpas_init. Ask about that later. For now, there will be
! no initial statistics write.
- if (config_initial_stats) then
+ if (config_write_stats_on_startup) then
call mpas_timer_start("global diagnostics", .false., globalDiagTimer)
call ocn_compute_global_diagnostics(domain, 1 , 0, dt)
call mpas_timer_stop("global diagnostics", globalDiagTimer)
@@ -184,11 +190,19 @@
type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime
type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep
+ character(len=StrKIND) :: restartTimeStamp
integer :: ierr
- call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
+ if(config_start_time == 'file') then
+ open(22,file='restart_timestamp',form='formatted',status='old')
+ read(22,*) restartTimeStamp
+ close(22)
+ call mpas_set_time(curr_time=startTime, dateTimeString=restartTimeStamp, ierr=ierr)
+ else
+ call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
+ end if
+
call mpas_set_timeInterval(timeStep, dt=dt, ierr=ierr)
-
if (trim(config_run_duration) /= "none") then
call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
@@ -222,11 +236,11 @@
!TODO: use this code if we desire to convert config_stats_interval to alarms
!(must also change config_stats_interval type to character)
! set stats alarm, if necessary
- !if (trim(config_stats_interval) /= "none") then
- ! call mpas_set_timeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=ierr)
- ! alarmStartTime = startTime + alarmTimeStep
- ! call mpas_add_clock_alarm(clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
- !end if
+ if (trim(config_stats_interval) /= "none") then
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+ end if
call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
@@ -249,6 +263,7 @@
integer :: i, iEdge, iCell, k
integer :: err1
+ call ocn_setup_sign_and_index_fields(mesh)
call ocn_initialize_advection_rk(mesh, err)
call mpas_tracer_advection_coefficients(mesh, err1, mesh % maxLevelCell % array, mesh % highOrderAdvectionMask % array, mesh % boundaryCell % array)
err = ior(err, err1)
@@ -264,8 +279,6 @@
= block % state % time_levs(1) % state % u % array(:,:) &
+ block % state % time_levs(1) % state % uBolusGM % array(:,:)
- call ocn_wtop(block % state % time_levs(1) % state,block % state % time_levs(1) % state, mesh)
-
call ocn_compute_mesh_scaling(mesh)
call mpas_rbf_interp_initialize(mesh)
@@ -351,7 +364,9 @@
call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
write(0,*) 'Initial time ', trim(timeStamp)
- call ocn_write_output_frame(output_obj, output_frame, domain)
+ if (config_write_output_on_startup) then
+ call ocn_write_output_frame(output_obj, output_frame, domain)
+ endif
block_ptr => domain % blocklist
do while(associated(block_ptr))
@@ -390,7 +405,8 @@
if (mpas_is_alarm_ringing(clock, outputAlarmID, ierr=ierr)) then
call mpas_reset_clock_alarm(clock, outputAlarmID, ierr=ierr)
- ! output_frame will always be > 1 here unless it was reset after the maximum number of frames per outfile was reached
+ ! output_frame will always be > 1 here unless it was reset after the
+ ! maximum number of frames per outfile was reached.
if(output_frame == 1) then
call mpas_output_state_finalize(output_obj, domain % dminfo)
call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp))
@@ -504,35 +520,37 @@
call ocn_timestep(domain, dt, timeStamp)
- if (config_stats_interval > 0) then
- if (mod(itimestep, config_stats_interval) == 0) then
- call mpas_timer_start("global diagnostics", .false., globalDiagTimer)
- call ocn_compute_global_diagnostics(domain, 2, itimestep, dt);
- call mpas_timer_stop("global diagnostics", globalDiagTimer)
- end if
- end if
+ !if (config_stats_interval > 0) then
+ ! if (mod(itimestep, config_stats_interval) == 0) then
+ ! call mpas_timer_start("global diagnostics", .false., globalDiagTimer)
+ ! call ocn_compute_global_diagnostics(domain, 2, itimestep, dt);
+ ! call mpas_timer_stop("global diagnostics", globalDiagTimer)
+ ! end if
+ !end if
!TODO: replace the above code block with this if we desire to convert config_stats_interval to use alarms
- !if (mpas_is_alarm_ringing(clock, statsAlarmID, ierr=ierr)) then
- ! call mpas_reset_clock_alarm(clock, statsAlarmID, ierr=ierr)
+ if (mpas_is_alarm_ringing(clock, statsAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, statsAlarmID, ierr=ierr)
- ! block_ptr => domain % blocklist
- ! if (associated(block_ptr % next)) then
- ! write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
- ! 'that there is only one block per processor.'
- ! end if
+! block_ptr => domain % blocklist
+! if (associated(block_ptr % next)) then
+! write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
+! 'that there is only one block per processor.'
+! end if
- ! call mpas_timer_start("global diagnostics")
- ! call ocn_compute_global_diagnostics(domain % dminfo, &
- ! block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
- ! timeStamp, dt)
- ! call mpas_timer_stop("global diagnostics")
- !end if
+ call mpas_timer_start("global diagnostics")
+ call ocn_compute_global_diagnostics(domain, 2, itimestep, dt);
+ ! call ocn_compute_global_diagnostics(domain % dminfo, &
+ ! block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
+ ! timeStamp, dt)
+ call mpas_timer_stop("global diagnostics")
+ end if
end subroutine mpas_timestep!}}}
- subroutine ocn_init_z_level(domain)!{{{
- ! Initialize zlevel-type variables
+ subroutine ocn_init_vert_coord(domain)!{{{
+ ! Initialize zlevel-type variables and adjust initial conditions for
+ ! partial bottom cells.
use mpas_grid_types
use mpas_configure
@@ -540,75 +558,189 @@
implicit none
type (domain_type), intent(inout) :: domain
+ type (dm_info) :: dminfo
- integer :: i, iCell, iEdge, iVertex, k
+ integer :: i, iCell, iEdge, iVertex, k, nCells, num_tracers
type (block_type), pointer :: block
integer :: iTracer, cell, cell1, cell2
- real (kind=RKIND) :: uhSum, hSum, hEdge1
- real (kind=RKIND), dimension(:), pointer :: referenceBottomDepth, &
- referenceBottomDepthTopOfCell, zstarWeight, hZLevel
+ real (kind=RKIND) :: uhSum, hSum, hEdge1, zMidPBC
+
+ integer, dimension(:), pointer :: maxLevelCell
+ real (kind=RKIND), dimension(:), pointer :: refBottomDepth, &
+ refBottomDepthTopOfCell, vertCoordMovementWeights, hZLevel, bottomDepth
+ real (kind=RKIND), dimension(:), allocatable :: minBottomDepth, minBottomDepthMid, zMidZLevel
real (kind=RKIND), dimension(:,:), pointer :: h
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers
integer :: nVertLevels
+ logical :: consistentSSH
! Initialize z-level grid variables from h, read in from input file.
block => domain % blocklist
do while (associated(block))
h => block % state % time_levs(1) % state % h % array
- referenceBottomDepth => block % mesh % referenceBottomDepth % array
- referenceBottomDepthTopOfCell => block % mesh % referenceBottomDepthTopOfCell % array
- zstarWeight => block % mesh % zstarWeight % array
+ tracers => block % state % time_levs(1) % state % tracers % array
+ refBottomDepth => block % mesh % refBottomDepth % array
+ refBottomDepthTopOfCell => block % mesh % refBottomDepthTopOfCell % array
+ bottomDepth => block % mesh % bottomDepth % array
+ vertCoordMovementWeights => block % mesh % vertCoordMovementWeights % array
hZLevel => block % mesh % hZLevel % array
+ maxLevelCell => block % mesh % maxLevelCell % array
+
+ nCells = block % mesh % nCells
nVertLevels = block % mesh % nVertLevels
+ num_tracers = size(tracers, dim=1)
! mrp 120208 right now hZLevel is in the grid.nc file.
- ! We would like to transition to using referenceBottomDepth
+ ! We would like to transition to using refBottomDepth
! as the defining variable instead, and will transition soon.
! When the transition is done, hZLevel can be removed from
! registry and the following four lines deleted.
- referenceBottomDepth(1) = hZLevel(1)
+ refBottomDepth(1) = hZLevel(1)
do k = 2,nVertLevels
- referenceBottomDepth(k) = referenceBottomDepth(k-1) + hZLevel(k)
+ refBottomDepth(k) = refBottomDepth(k-1) + hZLevel(k)
end do
! TopOfCell needed where zero depth for the very top may be referenced.
- referenceBottomDepthTopOfCell(1) = 0.0
+ refBottomDepthTopOfCell(1) = 0.0
do k = 1,nVertLevels
- referenceBottomDepthTopOfCell(k+1) = referenceBottomDepth(k)
+ refBottomDepthTopOfCell(k+1) = refBottomDepth(k)
end do
- ! Initialization of zstarWeights. This determines how SSH perturbations
+ ! Initialization of vertCoordMovementWeights. This determines how SSH perturbations
! are distributed throughout the column.
- if (config_vert_grid_type.eq.'zlevel') then
+ if (config_vert_coord_movement.eq.'fixed') then
- zstarWeight = 0.0
- zstarWeight(1) = 1.0
+ vertCoordMovementWeights = 0.0
+ vertCoordMovementWeights(1) = 1.0
- elseif (config_vert_grid_type.eq.'zstar') then
+ elseif (config_vert_coord_movement.eq.'uniform_stretching') then
- do k = 1,nVertLevels
- zstarWeight(k) = hZLevel(k)
+ vertCoordMovementWeights = 1.0
+
+ endif
+
+ ! Initial condition files (ocean.nc, produced by basin) include a realistic
+ ! bottomDepth variable and h,T,S variables for full thickness cells.
+ ! If running with pbcs, set config_alter_ICs_for_pbc='zlevel_pbcs_on'. Then thin pbc cells
+ ! will be changed, and h,T,S will be altered to match the pbcs.
+ ! If running without pbcs, set config_alter_ICs_for_pbc='zlevel_pbcs_off'. Then
+ ! bottomDepth will be altered so it is full cells everywhere.
+ ! If your input file does not include bottomDepth, the false option will
+ ! initialize bottomDepth correctly for a non-pbc run.
+
+
+ if (.not.config_do_restart) then
+
+ if (config_alter_ICs_for_pbcs.eq.'zlevel_pbcs_on') then
+
+ write (0,'(a)') ' Altering bottomDepth to avoid very thin cells.'
+ write (0,'(a)') ' Altering h and tracer initial conditions to conform with partial bottom cells.'
+
+ allocate(minBottomDepth(nVertLevels),minBottomDepthMid(nVertLevels),zMidZLevel(nVertLevels))
+
+ ! min_pbc_fraction restricts pbcs from being too small.
+ ! A typical value is 10%, so pbcs must occupy at least 10% of the cell thickness.
+ ! If min_pbc_fraction = 0.0, bottomDepth gives the actual depth for that cell.
+ ! If min_pbc_fraction = 1.0, bottomDepth reverts to discrete z-level depths, same
+ ! as partial_bottom_cells = .false.
+
+ do k=1,nVertLevels
+ minBottomDepth(k) = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*hZLevel(k)
+ minBottomDepthMid(k) = 0.5*(minBottomDepth(k) + refBottomDepthTopOfCell(k))
+ zMidZLevel(k) = - 0.5*(refBottomDepth(k) + refBottomDepthTopOfCell(k))
enddo
- elseif (config_vert_grid_type.eq.'zstarWeights') then
+ do iCell=1,nCells
+ k = maxLevelCell(iCell)
- ! This is a test with other weights, just to make sure zstar functions
- ! using variable weights.
-
- zstarWeight = 0.0
- zstarWeight(1:5) = 1.0
- do k=1,10
- zstarWeight(5+k) = 1.0-k*0.1
- end do
+ if (bottomDepth(iCell).lt.minBottomDepthMid(k)) then
+ ! Round up to cell above
+ maxLevelCell(iCell) = maxLevelCell(iCell) - 1
+ bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell))
+ elseif (bottomDepth(iCell).lt.minBottomDepth(k)) then
+ ! Round down cell to the min_pbc_fraction.
+ bottomDepth(iCell) = minBottomDepth(k)
+ endif
+ k = maxLevelCell(iCell)
+ ! Alter thickness of bottom level to account for PBC
+ h(k,iCell) = bottomDepth(iCell) - refBottomDepthTopOfCell(k)
+
+ ! Linearly interpolate the initial T&S for new location of bottom cell for PBCs
+ zMidPBC = -0.5*(bottomDepth(iCell) + refBottomDepthTopOfCell(k))
+
+ do iTracer=1,num_tracers
+ tracers(iTracer,k,iCell) = tracers(iTracer,k,iCell) &
+ + (tracers(iTracer,k-1,iCell) - tracers(iTracer,k,iCell)) &
+ /(zMidZLevel(k-1)-zMidZLevel(k)) &
+ *(zMidPBC - zMidZLevel(k))
+ enddo
+
+ enddo
+
+ deallocate(minBottomDepth,zMidZLevel)
+
+ elseif (config_alter_ICs_for_pbcs.eq.'zlevel_pbcs_off') then
+
+ do iCell = 1,nCells
+ bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell))
+ enddo
+
+ elseif (config_alter_ICs_for_pbcs.eq.'off') then
+ ! No action taken. This is for isopycnal or sigma coordinates,
+ ! or if ICs were already altered upon start-up.
+
+ else
+
+ write (0,*) ' Incorrect choice of config_alter_ICs_for_pbcs.'
+ call mpas_dmpar_abort(dminfo)
+
+ endif
endif
+ if (config_check_ssh_consistency) then
+ consistentSSH = .true.
+ do iCell = 1,nCells
+ ! Check if abs(ssh)>2m. If so, print warning.
+ if (abs(sum(h(1:maxLevelCell(iCell),iCell))-bottomDepth(iCell))>2.0) then
+ consistentSSH = .false.
+#ifdef MPAS_DEBUG
+ write (0,'(a)') ' Warning: abs(sum(h)-bottomDepth)>2m. Most likely, initial h does not match bottomDepth.'
+ write (0,*) ' iCell, K=maxLevelCell(iCell), bottomDepth(iCell),sum(h),bottomDepth,hZLevel(K),h(K): ', &
+ iCell, maxLevelCell(iCell), bottomDepth(iCell),sum(h(1:maxLevelCell(iCell),iCell)),bottomDepth(iCell), &
+ hZLevel(maxLevelCell(iCell)), h(maxLevelCell(iCell),iCell)
+#endif
+ endif
+ enddo
+
+ if (.not. consistentSSH) then
+ write(0,*) 'Warning: SSH is not consistent. Most likely, initial h does not match bottomDepth.'
+ end if
+ endif
+
+ if (config_check_zlevel_consistency) then
+ do iCell = 1,nCells
+ ! Check that bottomDepth and maxLevelCell match. Some older grids do not have the bottomDepth variable.
+ if (bottomDepth(iCell) > refBottomDepth(maxLevelCell(iCell)).or. &
+ bottomDepth(iCell) < refBottomDepthTopOfCell(maxLevelCell(iCell))) then
+ write (0,'(a)') ' fatal error: bottomDepth and maxLevelCell do not match:'
+ write (0,'(a,2i5,10f10.2)') ' iCell, maxLevelCell(iCell), bottomDepth(iCell): ', &
+ iCell, maxLevelCell(iCell), bottomDepth(iCell)
+ write (0,'(a,10f10.2)') ' refBottomDepth(maxLevelCell(iCell)), refBottomDepthTopOfCell(maxLevelCell(iCell)): ', &
+ refBottomDepth(maxLevelCell(iCell)), refBottomDepthTopOfCell(maxLevelCell(iCell))
+ call mpas_dmpar_abort(dminfo)
+ endif
+
+ enddo
+ endif
+
block => block % next
end do
- end subroutine ocn_init_z_level!}}}
+ end subroutine ocn_init_vert_coord!}}}
subroutine ocn_init_split_timestep(domain)!{{{
! Initialize splitting variables
@@ -625,7 +757,7 @@
integer :: iTracer, cell, cell1, cell2
real (kind=RKIND) :: uhSum, hSum, hEdge1
- real (kind=RKIND), dimension(:), pointer :: referenceBottomDepth
+ real (kind=RKIND), dimension(:), pointer :: refBottomDepth
real (kind=RKIND), dimension(:,:), pointer :: h
integer :: nVertLevels
@@ -635,23 +767,23 @@
do while (associated(block))
h => block % state % time_levs(1) % state % h % array
- referenceBottomDepth => block % mesh % referenceBottomDepth % array
+ refBottomDepth => block % mesh % refBottomDepth % array
nVertLevels = block % mesh % nVertLevels
! Compute barotropic velocity at first timestep
! This is only done upon start-up.
- if (trim(config_time_integration) == 'unsplit_explicit') then
+ if (trim(config_time_integrator) == 'unsplit_explicit') then
block % state % time_levs(1) % state % uBtr % array(:) = 0.0
block % state % time_levs(1) % state % uBcl % array(:,:) &
= block % state % time_levs(1) % state % u % array(:,:)
- elseif (trim(config_time_integration) == 'split_explicit') then
+ elseif (trim(config_time_integrator) == 'split_explicit') then
if (config_filter_btr_mode) then
do iCell=1,block % mesh % nCells
block % state % time_levs(1) % state % h % array(1,iCell) &
- = block % mesh % referenceBottomDepth % array(1)
+ = block % mesh % refBottomDepth % array(1)
enddo
endif
@@ -715,64 +847,6 @@
end subroutine ocn_init_split_timestep!}}}
- subroutine ocn_init_h_zstar(domain)!{{{
- ! If changing from zlevel to zstar, compute h based on zstar weights,
- ! where SSH is distributed through the layers. We only change h.
- ! We do not remap the tracer variables, so this breaks total global
- ! conservation.
-
- use mpas_grid_types
- use mpas_configure
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- type (block_type), pointer :: block
-
- integer :: i, iCell, iEdge, iVertex, k, nVertLevels
- integer, dimension(:), pointer :: maxLevelCell
-
- real (kind=RKIND) :: hSum, sumZstarWeights
- real (kind=RKIND), dimension(:), pointer :: hZLevel, zstarWeight, &
- referenceBottomDepth
- real (kind=RKIND), dimension(:,:), pointer :: h
-
- ! Initialize z-level grid variables from h, read in from input file.
- block => domain % blocklist
- do while (associated(block))
-
- h => block % state % time_levs(1) % state % h % array
- nVertLevels = block % mesh % nVertLevels
- hZLevel => block % mesh % hZLevel % array
- maxLevelCell => block % mesh % maxLevelCell % array
- zstarWeight => block % mesh % zstarWeight % array
- referenceBottomDepth => block % mesh % referenceBottomDepth % array
-
- do iCell=1,block % mesh % nCells
- ! Compute the total column thickness, hSum, and the sum of zstar weights.
- hSum = 0.0
- sumZstarWeights = 0.0
- do k = 1,maxLevelCell(iCell)
- hSum = hSum + h(k,iCell)
- sumZstarWeights = sumZstarWeights + zstarWeight(k)
- enddo
-
- ! h_k = h_k^{zlevel} + zeta * W_k/sum(W_k)
- ! where zeta is SSH and W_k are weights
- do k = 1,maxLevelCell(iCell)
- h(k,iCell) = hZLevel(k) &
- + (hSum - referenceBottomDepth(maxLevelCell(iCell))) &
- * zstarWeight(k)/sumZstarWeights
- enddo
-
- enddo
-
- block => block % next
- end do
-
- end subroutine ocn_init_h_zstar!}}}
-
subroutine ocn_compute_max_level(domain)!{{{
! Initialize maxLevel and bouncary grid variables.
@@ -787,10 +861,6 @@
integer :: i, iCell, iEdge, iVertex, k
type (block_type), pointer :: block
- 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, vertexDegree
integer, dimension(:), pointer :: &
@@ -827,7 +897,7 @@
! for z-grids, maxLevelCell should be in input state
! Isopycnal grid uses all vertical cells
- if (config_vert_grid_type.eq.'isopycnal') then
+ if (config_vert_coord_movement.eq.'isopycnal') then
maxLevelCell(1:nCells) = nVertLevels
endif
maxLevelCell(nCells+1) = 0
@@ -948,7 +1018,7 @@
meshScalingDel2(:) = 1.0
meshScalingDel4(:) = 1.0
meshScaling(:) = 1.0
- if (config_h_ScaleWithMesh) then
+ if (config_hmix_ScaleWithMesh) then
do iEdge=1,mesh%nEdges
cell1 = mesh % cellsOnEdge % array(1,iEdge)
cell2 = mesh % cellsOnEdge % array(2,iEdge)
@@ -960,6 +1030,72 @@
end subroutine ocn_compute_mesh_scaling!}}}
+ subroutine ocn_setup_sign_and_index_fields(mesh)!{{{
+
+ type (mesh_type), intent(inout) :: mesh
+
+ integer, dimension(:), pointer :: nEdgesOnCell
+ integer, dimension(:,:), pointer :: edgesOnCell, edgesOnVertex, cellsOnVertex, cellsOnEdge, verticesOnCell, verticesOnEdge
+ integer, dimension(:,:), pointer :: edgeSignOnCell, edgeSignOnVertex, kiteIndexOnCell
+
+ integer :: nCells, nEdges, nVertices, vertexDegree
+ integer :: iCell, iEdge, iVertex, i, j, k
+
+ nCells = mesh % nCells
+ nEdges = mesh % nEdges
+ nVertices = mesh % nVertices
+ vertexDegree = mesh % vertexDegree
+
+ nEdgesOnCell => mesh % nEdgesOnCell % array
+ edgesOnCell => mesh % edgeSOnCell % array
+ edgesOnVertex => mesh % edgesOnVertex % array
+ cellsOnVertex => mesh % cellsOnVertex % array
+ cellsOnEdge => mesh % cellsOnEdge % array
+ verticesOnCell => mesh % verticesOnCell % array
+ verticesOnEdge => mesh % verticesOnEdge % array
+ edgeSignOnCell => mesh % edgeSignOnCell % array
+ edgeSignOnVertex => mesh % edgeSignOnVertex % array
+ kiteIndexOnCell => mesh % kiteIndexOnCell % array
+
+ edgeSignOnCell = 0.0_RKIND
+ edgeSignOnVertex = 0.0_RKIND
+ kiteIndexOnCell = 0.0_RKIND
+
+ do iCell = 1, nCells
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+ iVertex = verticesOnCell(i, iCell)
+
+ ! Vector points from cell 1 to cell 2
+ if(iCell == cellsOnEdge(1, iEdge)) then
+ edgeSignOnCell(i, iCell) = -1
+ else
+ edgeSignOnCell(i, iCell) = 1
+ end if
+
+ do j = 1, vertexDegree
+ if(cellsOnVertex(j, iVertex) == iCell) then
+ kiteIndexOnCell(i, iCell) = j
+ end if
+ end do
+ end do
+ end do
+
+ do iVertex = 1, nVertices
+ do i = 1, vertexDegree
+ iEdge = edgesOnVertex(i, iVertex)
+
+ ! Vector points from vertex 1 to vertex 2
+ if(iVertex == verticesOnEdge(1, iEdge)) then
+ edgeSignOnVertex(i, iVertex) = -1
+ else
+ edgeSignOnVertex(i, iVertex) = 1
+ end if
+ end do
+ end do
+
+ end subroutine ocn_setup_sign_and_index_fields!}}}
+
end module mpas_core
! vim: foldmethod=marker
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tendency.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tendency.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tendency.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -8,9 +8,7 @@
!> \version SVN:$Id:$
!> \details
!> This module contains the routines for computing
-!> various tendencies for the ocean. As well as routines
-!> for computing diagnostic variables, and other quantities
-!> such as wTop.
+!> tendency terms for the ocean primitive equations.
!
!-----------------------------------------------------------------------
@@ -21,36 +19,28 @@
use mpas_constants
use mpas_timer
- use mpas_ocn_tracer_advection
+ use ocn_tracer_advection
use ocn_thick_hadv
use ocn_thick_vadv
- use ocn_gm
use ocn_vel_coriolis
use ocn_vel_pressure_grad
use ocn_vel_vadv
use ocn_vel_hmix
use ocn_vel_forcing
+ use ocn_vmix
- use ocn_tracer_hadv
- use ocn_tracer_vadv
use ocn_tracer_hmix
use ocn_restoring
- use ocn_equation_of_state
- use ocn_vmix
-
- use ocn_time_average
-
implicit none
private
save
- type (timer_node), pointer :: diagEOSTimer
type (timer_node), pointer :: thickHadvTimer, thickVadvTimer
- type (timer_node), pointer :: velCorTimer, velVadvTimer, velPgradTimer, velHmixTimer, velForceTimer, velExpVmixTimer
- type (timer_node), pointer :: tracerHadvTimer, tracerVadvTimer, tracerHmixTimer, tracerExpVmixTimer, tracerRestoringTimer
+ type (timer_node), pointer :: velCorTimer, velVadvTimer, velPgradTimer, velHmixTimer, velForceTimer
+ type (timer_node), pointer :: tracerHadvTimer, tracerVadvTimer, tracerHmixTimer, tracerRestoringTimer
!--------------------------------------------------------------------
!
@@ -66,13 +56,8 @@
public :: ocn_tend_h, &
ocn_tend_u, &
- ocn_tend_scalar, &
- ocn_diagnostic_solve, &
- ocn_wtop, &
- ocn_fuperp, &
- ocn_tendency_init, &
- ocn_filter_btr_mode_u, &
- ocn_filter_btr_mode_tend_u
+ ocn_tend_tracer, &
+ ocn_tendency_init
!--------------------------------------------------------------------
!
@@ -80,11 +65,6 @@
!
!--------------------------------------------------------------------
- integer :: hadv2nd, hadv3rd, hadv4th
- integer :: ke_cell_flag, ke_vertex_flag
- real (kind=RKIND) :: coef_3rd_order, fCoef
-
-
!***********************************************************************
contains
@@ -126,6 +106,8 @@
!
tend_h = 0.0
+ if(config_disable_h_all_tend) return
+
!
! height tendency: horizontal advection term -</font>
<font color="gray">abla\cdot ( hu)
!
@@ -172,7 +154,7 @@
real (kind=RKIND), dimension(:,:), pointer :: &
h_edge, h, u, rho, zMid, pressure, &
- tend_u, circulation, vorticity, ke, ke_edge, Vor_edge, &
+ tend_u, circulation, vorticity, viscosity, ke, ke_edge, Vor_edge, &
MontPot, wTop, divergence, vertViscTopOfEdge
real (kind=RKIND), dimension(:,:), pointer :: u_src
@@ -186,6 +168,7 @@
wTop => s % wTop % array
zMid => s % zMid % array
h_edge => s % h_edge % array
+ viscosity => s % viscosity % array
vorticity => s % vorticity % array
divergence => s % divergence % array
ke => s % ke % array
@@ -205,6 +188,8 @@
! mrp 110516 efficiency: could remove next line and have first tend_u operation not be additive
tend_u(:,:) = 0.0
+ if(config_disable_u_all_tend) return
+
!
! velocity tendency: nonlinear Coriolis term and grad of kinetic energy
!
@@ -224,7 +209,7 @@
! velocity tendency: pressure gradient
!
call mpas_timer_start("pressure grad", .false., velPgradTimer)
- if (config_pressure_type.eq.'MontgomeryPotential') then
+ if (config_pressure_gradient_type.eq.'MontgomeryPotential') then
call ocn_vel_pressure_grad_tend(grid, MontPot, zMid, rho, tend_u, err)
else
call ocn_vel_pressure_grad_tend(grid, pressure, zMid, rho, tend_u, err)
@@ -234,10 +219,10 @@
!
! velocity tendency: del2 dissipation, </font>
<font color="black">u_2 </font>
<font color="black">abla^2 u
! computed as </font>
<font color="black">u( </font>
<font color="black">abla divergence + k \times </font>
<font color="gray">abla vorticity )
- ! strictly only valid for config_h_mom_eddy_visc2 == constant
+ ! strictly only valid for config_mom_del2 == constant
!
call mpas_timer_start("hmix", .false., velHmixTimer)
- call ocn_vel_hmix_tend(grid, divergence, vorticity, tend_u, err)
+ call ocn_vel_hmix_tend(grid, divergence, vorticity, viscosity, tend_u, err)
call mpas_timer_stop("hmix", velHmixTimer)
!
@@ -253,28 +238,23 @@
!
! velocity tendency: vertical mixing d/dz( nu_v du/dz))
!
- if (.not.config_implicit_vertical_mix) then
- call mpas_timer_start("explicit vmix", .false., velExpVmixTimer)
- call ocn_vel_vmix_tend_explicit(grid, u, h_edge, vertvisctopofedge, tend_u, err)
- call mpas_timer_stop("explicit vmix", velExpVmixTimer)
- endif
call mpas_timer_stop("ocn_tend_u")
end subroutine ocn_tend_u!}}}
!***********************************************************************
!
-! routine ocn_tendSalar
+! routine ocn_tend_tracer
!
-!> \brief Computes scalar tendency
+!> \brief Computes tracer tendency
!> \author Doug Jacobsen
!> \date 23 September 2011
!> \version SVN:$Id$
!> \details
-!> This routine computes the scalar (tracer) tendency for the ocean
+!> This routine computes tracer tendencies for the ocean
!
!-----------------------------------------------------------------------
- subroutine ocn_tend_scalar(tend, s, d, grid, dt)!{{{
+ subroutine ocn_tend_tracer(tend, s, d, grid, dt)!{{{
implicit none
type (tend_type), intent(inout) :: tend !< Input/Output: Tendency structure
@@ -290,7 +270,7 @@
integer :: err, iEdge, k
- call mpas_timer_start("ocn_tend_scalar")
+ call mpas_timer_start("ocn_tend_tracer")
uTransport => s % uTransport % array
h => s % h % array
@@ -302,6 +282,13 @@
tend_tr => tend % tracers % array
tend_h => tend % h % array
+ !
+ ! initialize tracer tendency (RHS of tracer equation) to zero.
+ !
+ tend_tr(:,:,:) = 0.0
+
+ if(config_disable_tr_all_tend) return
+
allocate(uh(grid % nVertLevels, grid % nEdges+1))
!
! QC Comment (3/15/12): need to make sure that uTransport is the right
@@ -313,11 +300,6 @@
end do
!
- ! initialize tracer tendency (RHS of tracer equation) to zero.
- !
- tend_tr(:,:,:) = 0.0
-
- !
! tracer tendency: horizontal advection term -div( h \phi u)
!
! mrp 101115 note: in order to include flux boundary conditions, we will need to
@@ -327,7 +309,7 @@
! Monotonoic Advection, or standard advection
call mpas_timer_start("adv", .false., tracerHadvTimer)
- call mpas_ocn_tracer_advection_tend(tracers, uh, wTop, h, h, dt, grid, tend_h, tend_tr)
+ call ocn_tracer_advection_tend(tracers, uh, wTop, h, h, dt, grid, tend_h, tend_tr)
call mpas_timer_stop("adv", tracerHadvTimer)
!
@@ -344,17 +326,7 @@
! maxval(tracers(3,1,1:nCells))
! mrp 110516 printing end
- !
- ! tracer tendency: vertical diffusion h d/dz( \kappa_v d\phi/dz)
- !
- if (.not.config_implicit_vertical_mix) then
- call mpas_timer_start("explicit vmix", .false., tracerExpVmixTimer)
- call ocn_tracer_vmix_tend_explicit(grid, h, vertdifftopofcell, tracers, tend_tr, err)
-
- call mpas_timer_stop("explicit vmix", tracerExpVmixTimer)
- endif
-
! mrp 110516 printing
!print *, 'tend_tr 2',minval(tend_tr(3,1,1:nCells)),&
! maxval(tend_tr(3,1,1:nCells))
@@ -370,782 +342,14 @@
call mpas_timer_stop("restoring", tracerRestoringTimer)
10 format(2i8,10e20.10)
- call mpas_timer_stop("ocn_tend_scalar")
+ call mpas_timer_stop("ocn_tend_tracer")
deallocate(uh)
- end subroutine ocn_tend_scalar!}}}
+ end subroutine ocn_tend_tracer!}}}
!***********************************************************************
!
-! routine ocn_diagnostic_solve
-!
-!> \brief Computes diagnostic variables
-!> \author Doug Jacobsen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the diagnostic variables for the ocean
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_diagnostic_solve(dt, s, grid)!{{{
- implicit none
-
- real (kind=RKIND), intent(in) :: dt !< Input: Time step
- type (state_type), intent(inout) :: s !< Input/Output: State information
- type (mesh_type), intent(in) :: grid !< Input: Grid information
-
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
- integer :: boundaryMask, velMask, nCells, nEdges, nVertices, nVertLevels, vertexDegree, err
-
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
- maxLevelVertexBot
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
- verticesOnEdge, edgesOnEdge, edgesOnVertex,boundaryCell
-
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2, coef_3rd_order, r_tmp, invAreaCell1, invAreaCell2, invAreaTri1, invAreaTri2, invLength, h_vertex
-
- real (kind=RKIND), dimension(:), allocatable:: pTop
-
- real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, dvEdge, dcEdge, areaCell, areaTriangle, &
- referenceBottomDepth, ssh
- real (kind=RKIND), dimension(:,:), pointer :: &
- weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure,&
- circulation, vorticity, ke, ke_edge, MontPot, wTop, zMid, &
- Vor_edge, Vor_vertex, Vor_cell, gradVor_n, gradVor_t, divergence, &
- rho, temperature, salinity, kev, kevc, uBolusGM, uTransport
- real (kind=RKIND), dimension(:,:,:), pointer :: tracers, deriv_two
- real (kind=RKIND), dimension(:,:), allocatable:: div_u
- character :: c1*6
-
- h => s % h % array
- u => s % u % array
- uTransport => s % uTransport % array
- uBolusGM => s % uBolusGM % array
- v => s % v % array
- h_edge => s % h_edge % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- kev => s % kev % array
- kevc => s % kevc % array
- ke_edge => s % ke_edge % array
- Vor_edge => s % Vor_edge % array
- Vor_vertex => s % Vor_vertex % array
- Vor_cell => s % Vor_cell % array
- gradVor_n => s % gradVor_n % array
- gradVor_t => s % gradVor_t % array
- rho => s % rho % array
- MontPot => s % MontPot % array
- pressure => s % pressure % array
- zMid => s % zMid % array
- ssh => s % ssh % array
- tracers => s % tracers % array
-
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
- fVertex => grid % fVertex % array
- referenceBottomDepth => grid % referenceBottomDepth % array
- deriv_two => grid % deriv_two % array
- maxLevelCell => grid % maxLevelCell % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelEdgeBot => grid % maxLevelEdgeBot % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
- vertexDegree = grid % vertexDegree
-
- boundaryCell => grid % boundaryCell % array
-
-
- !
- ! Compute height on cell edges at velocity locations
- ! Namelist options control the order of accuracy of the reconstructed h_edge value
- !
- ! mrp 101115 note: in order to include flux boundary conditions, we will need to
- ! assign h_edge for maxLevelEdgeTop:maxLevelEdgeBot in the following section
-
- ! initialize h_edge to avoid divide by zero and NaN problems.
- h_edge = -1.0e34
- coef_3rd_order = config_coef_3rd_order
-
- do iEdge=1,nEdges*hadv2nd
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end do
-
- do iEdge=1,nEdges*hadv3rd
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,maxLevelEdgeTop(iEdge)
-
- d2fdx2_cell1 = 0.0
- d2fdx2_cell2 = 0.0
-
- boundaryMask = abs(transfer(.not.(boundaryCell(k,cell1) == 0 .and. boundaryCell(k,cell2) == 0), boundaryMask))
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1) * boundaryMask
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2) * boundaryMask
-
- !-- all edges of cell 1
- do i=1, nEdgesOnCell(cell1) * boundaryMask
- 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, nEdgesOnCell(cell2) * boundaryMask
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- velMask = 2*(abs(transfer(u(k,iEdge) <= 0, velMask))) - 1
-
- h_edge(k,iEdge) = 0.5*(h(k,cell1) + h(k,cell2)) - (dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- + velMask * (dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
-
- end do ! do k
- end do ! do iEdge
-
- do iEdge=1,nEdges*hadv4th
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,maxLevelEdgeTop(iEdge)
-
- d2fdx2_cell1 = 0.0
- d2fdx2_cell2 = 0.0
-
- boundaryMask = abs(transfer(.not.(boundaryCell(k,cell1) == 0 .and. boundaryCell(k,cell2) == 0), boundaryMask))
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1) * boundaryMask
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2) * boundaryMask
-
- !-- all edges of cell 1
- do i=1, nEdgesOnCell(cell1) * boundaryMask
- 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, nEdgesOnCell(cell2) * boundaryMask
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- 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 do ! do iEdge
-
- !
- ! set the velocity and height at dummy address
- ! used -1e34 so error clearly occurs if these values are used.
- !
- u(:,nEdges+1) = -1e34
- h(:,nCells+1) = -1e34
- tracers(s % index_temperature,:,nCells+1) = -1e34
- tracers(s % index_salinity,:,nCells+1) = -1e34
-
- circulation(:,:) = 0.0
- vorticity(:,:) = 0.0
- divergence(:,:) = 0.0
- ke(:,:) = 0.0
- v(:,:) = 0.0
- do iEdge=1,nEdges
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- invAreaTri1 = 1.0 / areaTriangle(vertex1)
- invAreaTri2 = 1.0 / areaTriangle(vertex2)
-
- !dwj: 02/23/12 arraCell(nCells+1) is still 0, this is a temporary fix
- invAreaCell1 = 1.0 / max(areaCell(cell1), 1.0)
- invAreaCell2 = 1.0 / max(areaCell(cell2), 1.0)
-
- do k=1,maxLevelEdgeBot(iEdge)
- ! Compute circulation and relative vorticity at each vertex
- r_tmp = dcEdge(iEdge) * u(k,iEdge)
- circulation(k,vertex1) = circulation(k,vertex1) - r_tmp
- circulation(k,vertex2) = circulation(k,vertex2) + r_tmp
-
- vorticity(k, vertex1) = vorticity(k, vertex1) - r_tmp * invAreaTri1
- vorticity(k, vertex2) = vorticity(k, vertex2) + r_tmp * invAreaTri2
-
- ! Compute the divergence at each cell center
- r_tmp = dvEdge(iEdge) * u(k, iEdge)
- divergence(k,cell1) = divergence(k,cell1) + r_tmp * invAreaCell1
- divergence(k,cell2) = divergence(k,cell2) - r_tmp * invAreaCell2
-
- ! Compute kinetic energy in each cell
- r_tmp = r_tmp * dcEdge(iEdge) * u(k,iEdge)
- ke(k,cell1) = ke(k,cell1) + 0.25 * r_tmp * invAreaCell1
- ke(k,cell2) = ke(k,cell2) + 0.25 * r_tmp * invAreaCell2
- end do
-
- ! Compute v (tangential) velocities
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- ! mrp 101115 note: in order to include flux boundary conditions,
- ! the following loop may need to change to maxLevelEdgeBot
- do k = 1,maxLevelEdgeTop(iEdge)
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end do
-
- end do
-
- !
- ! Compute kinetic energy in each vertex
- !
- kev(:,:) = 0.0; kevc(:,:) = 0.0
- do iEdge=1,nEdges*ke_vertex_flag
- do k=1,nVertLevels
- r_tmp = dcEdge(iEdge) * dvEdge(iEdge) * u(k, iEdge)**2
- kev(k,verticesOnEdge(1,iEdge)) = kev(k,verticesOnEdge(1,iEdge)) + r_tmp
- kev(k,verticesOnEdge(2,iEdge)) = kev(k,verticesOnEdge(2,iEdge)) + r_tmp
- end do
- end do
- do iVertex = 1,nVertices*ke_vertex_flag
- do k=1,nVertLevels
- kev(k,iVertex) = kev(k,iVertex) / areaTriangle(iVertex) * 0.25
- enddo
- enddo
- do iVertex = 1, nVertices*ke_vertex_flag
- do i=1,grid % vertexDegree
- iCell = cellsOnVertex(i,iVertex)
- !dwj: 02/23/12 arraCell(nCells+1) is still 0, this is a temporary fix
- invAreaCell1 = 1.0 / max(areaCell(iCell), 1.0)
- do k=1,nVertLevels
- kevc(k,iCell) = kevc(k,iCell) + kiteAreasOnVertex(i, iVertex) * kev(k, iVertex) * invAreaCell1
- enddo
- enddo
- enddo
-
- !
- ! Compute kinetic energy in each cell by blending ke and kevc
- !
- do iCell=1,nCells*ke_vertex_flag
- do k=1,nVertLevels
- ke(k,iCell) = 5.0/8.0*ke(k,iCell) + 3.0/8.0*kevc(k,iCell)
- end do
- end do
-
- !
- ! Compute ke on cell edges at velocity locations for quadratic bottom drag.
- !
- ! mrp 101025 efficiency note: we could get rid of ke_edge completely by
- ! using sqrt(u(k,iEdge)**2 + v(k,iEdge)**2) in its place elsewhere.
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
- ke_edge(k,iEdge) = 0.5 * (ke(k,cell1) + ke(k,cell2))
- end do
- end do
-
- !
- ! Compute height at vertices, pv at vertices, and average pv to edge locations
- ! ( this computes Vor_vertex at all vertices bounding real cells and distance-1 ghost cells )
- !
- do iVertex = 1,nVertices
- invAreaTri1 = 1.0 / areaTriangle(iVertex)
- do k=1,maxLevelVertexBot(iVertex)
- h_vertex = 0.0
- do i=1,vertexDegree
- h_vertex = h_vertex + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
- end do
- h_vertex = h_vertex * invAreaTri1
-
- Vor_vertex(k,iVertex) = (fCoef*fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
- end do
- end do
-
- Vor_cell(:,:) = 0.0
- Vor_edge(:,:) = 0.0
- do iVertex = 1,nVertices
- do i=1,vertexDegree
- iCell = cellsOnVertex(i,iVertex)
- iEdge = edgesOnVertex(i,iVertex)
-
- !dwj: 02/23/12 arraCell(nCells+1) is still 0, this is a temporary fix
- invAreaCell1 = 1.0 / max(areaCell(iCell), 1.0)
-
- ! Compute pv at cell centers
- ! ( this computes Vor_cell for all real cells and distance-1 ghost cells )
- do k = 1,maxLevelCell(iCell)
- Vor_cell(k,iCell) = Vor_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * Vor_vertex(k, iVertex) * invAreaCell1
- enddo
-
- ! Compute pv at the edges
- ! ( this computes Vor_edge at all edges bounding real cells )
- do k=1,maxLevelEdgeBot(iEdge)
- Vor_edge(k,iEdge) = Vor_edge(k,iEdge) + 0.5 * Vor_vertex(k,iVertex)
- enddo
- enddo
- enddo
-
-! gradVor_n(:,:) = 0.0
-! gradVor_t(:,:) = 0.0
- do iEdge = 1,nEdges
- cell1 = cellsOnEdge(1, iEdge)
- cell2 = cellsOnEdge(2, iEdge)
- vertex1 = verticesOnedge(1, iEdge)
- vertex2 = verticesOnedge(2, iEdge)
-
- invLength = 1.0 / dcEdge(iEdge)
- ! Compute gradient of PV in normal direction
- ! ( this computes gradVor_n for all edges bounding real cells )
- do k=1,maxLevelEdgeTop(iEdge)
- gradVor_n(k,iEdge) = (Vor_cell(k,cell2) - Vor_cell(k,cell1)) * invLength
- enddo
-
- invLength = 1.0 / dvEdge(iEdge)
- ! Compute gradient of PV in the tangent direction
- ! ( this computes gradVor_t at all edges bounding real cells and distance-1 ghost cells )
- do k = 1,maxLevelEdgeBot(iEdge)
- gradVor_t(k,iEdge) = (Vor_vertex(k,vertex2) - Vor_vertex(k,vertex1)) * invLength
- enddo
-
- enddo
-
- !
- ! Modify PV edge with upstream bias.
- !
- do iEdge = 1,nEdges
- do k = 1,maxLevelEdgeBot(iEdge)
- Vor_edge(k,iEdge) = Vor_edge(k,iEdge) &
- - config_apvm_scale_factor * dt* ( u(k,iEdge) * gradVor_n(k,iEdge) &
- + v(k,iEdge) * gradVor_t(k,iEdge) )
- enddo
- enddo
-
- !
- ! equation of state
- !
- ! For an isopycnal model, density should remain constant.
- ! For zlevel, calculate in-situ density
- if (config_vert_grid_type.ne.'isopycnal') then
- call mpas_timer_start("equation of state", .false., diagEOSTimer)
- call ocn_equation_of_state_rho(s, grid, 0, 'relative', err)
- ! mrp 110324 In order to visualize rhoDisplaced, include the following
- call ocn_equation_of_state_rho(s, grid, 1, 'relative', err)
- call mpas_timer_stop("equation of state", diagEOSTimer)
- endif
-
- !
- ! Pressure
- ! This section must be after computing rho
- !
- ! dwj: 10/25/2011 - Need to explore isopycnal vs zlevel flags
- if (config_pressure_type.eq.'MontgomeryPotential') then
-
- ! For Isopycnal model.
- ! Compute pressure at top of each layer, and then
- ! Montgomery Potential.
- allocate(pTop(nVertLevels))
- do iCell=1,nCells
-
- ! assume atmospheric pressure at the surface is zero for now.
- pTop(1) = 0.0
- ! For isopycnal mode, p is the Montgomery Potential.
- ! At top layer it is g*SSH, where SSH may be off by a
- ! constant (ie, h_s can be relative to top or bottom)
- MontPot(1,iCell) = gravity &
- * (h_s(iCell) + sum(h(1:nVertLevels,iCell)))
-
- do k=2,nVertLevels
- pTop(k) = pTop(k-1) + rho(k-1,iCell)*gravity* h(k-1,iCell)
-
- ! from delta M = p delta / rho
- MontPot(k,iCell) = MontPot(k-1,iCell) &
- + pTop(k)*(1.0/rho(k,iCell) - 1.0/rho(k-1,iCell))
- end do
-
- end do
- deallocate(pTop)
-
- else
-
- do iCell=1,nCells
- ! pressure for generalized coordinates
- ! assume atmospheric pressure at the surface is zero for now.
- pressure(1,iCell) = rho(1,iCell)*gravity &
- * 0.5*h(1,iCell)
-
- do k=2,maxLevelCell(iCell)
- pressure(k,iCell) = pressure(k-1,iCell) &
- + 0.5*gravity*( rho(k-1,iCell)*h(k-1,iCell) &
- + rho(k ,iCell)*h(k ,iCell))
- end do
-
- ! Compute zMid, the z-coordinate of the middle of the layer.
- ! This is used for the rho g grad z momentum term.
- ! Note the negative sign, since referenceBottomDepth is positive
- ! and z-coordinates are negative below the surface.
- k = maxLevelCell(iCell)
- zMid(k:nVertLevels,iCell) = -referenceBottomDepth(k) + 0.5*h(k,iCell)
-
- do k=maxLevelCell(iCell)-1, 1, -1
- zMid(k,iCell) = zMid(k+1,iCell) &
- + 0.5*( h(k+1,iCell) &
- + h(k ,iCell))
- end do
-
- end do
-
- endif
-
- !
- ! Sea Surface Height
- !
- do iCell=1,nCells
- ! Start at the bottom where we know the depth, and go up.
- ! The bottom depth for this cell is
- ! referenceBottomDepth(maxLevelCell(iCell)).
- ! Note the negative sign, since referenceBottomDepth is positive
- ! and z-coordinates are negative below the surface.
-
- ssh(iCell) = -referenceBottomDepth(maxLevelCell(iCell)) &
- + sum(h(1:maxLevelCell(iCell),iCell))
-
- end do
-
- !
- ! Apply the GM closure as a bolus velocity
- !
- if (config_h_kappa .GE. epsilon(0D0)) then
- call ocn_gm_compute_uBolus(s,grid)
- else
- ! mrp efficiency note: if uBolusGM is guaranteed to be zero, this can be removed.
- uBolusGM = 0.0
- end if
-
- end subroutine ocn_diagnostic_solve!}}}
-
-!***********************************************************************
-!
-! routine ocn_wtop
-!
-!> \brief Computes vertical velocity
-!> \author Doug Jacobsen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the vertical velocity in the top layer for the ocean
-!
-!-----------------------------------------------------------------------
- subroutine ocn_wtop(s1,s2, grid)!{{{
- implicit none
-
- type (state_type), intent(inout) :: s1 !< Input/Output: State 1 information
- type (state_type), intent(inout) :: s2 !< Input/Output: State 2 information
- type (mesh_type), intent(in) :: grid !< Input: Grid information
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, rho0Inv, hSum
-
- integer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree
-
-
- real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, zstarWeight
- real (kind=RKIND), dimension(:,:), pointer :: uTransport,h,wTop, h_edge
- real (kind=RKIND), dimension(:,:), allocatable:: div_hu
- real (kind=RKIND), dimension(:), allocatable:: div_hu_btr, h_tend_col
-
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
- verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, &
- boundaryEdge, boundaryCell
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
- maxLevelVertexBot, maxLevelVertexTop
-
- h => s1 % h % array
- h_edge => s1 % h_edge % array
- uTransport => s2 % uTransport % array
- wTop => s2 % wTop % array
-
- areaCell => grid % areaCell % array
- cellsOnEdge => grid % cellsOnEdge % array
- maxLevelCell => grid % maxLevelCell % array
- maxLevelEdgeBot => grid % maxLevelEdgeBot % array
- dvEdge => grid % dvEdge % array
- zstarWeight => grid % zstarWeight % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
-
- allocate(div_hu(nVertLevels,nCells+1), div_hu_btr(nCells+1), &
- h_tend_col(nVertLevels))
-
- !
- ! Compute div(h^{edge} u) for each cell
- ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
- !
- div_hu(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeBot(iEdge)
- flux = uTransport(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
- div_hu(k,cell1) = div_hu(k,cell1) + flux
- div_hu(k,cell2) = div_hu(k,cell2) - flux
- end do
- end do
-
- do iCell=1,nCells
- div_hu_btr(iCell) = 0.0
- do k=1,maxLevelCell(iCell)
- div_hu(k,iCell) = div_hu(k,iCell) / areaCell(iCell)
- div_hu_btr(iCell) = div_hu_btr(iCell) + div_hu(k,iCell)
- end do
- end do
-
- !
- ! vertical velocity through layer interface
- !
- !dwj: 10/25/2011 - Need to explore isopycnal vs zlevel flags
- if (config_vert_grid_type.eq.'isopycnal') then
- ! set vertical velocity to zero in isopycnal case
- wTop=0.0
-
- else ! zlevel or zstar type vertical grid
-
- do iCell=1,nCells
-
- hSum = 0.0
- do k=1,maxLevelCell(iCell)
- h_tend_col(k) = - zstarWeight(k)*h(k,iCell)*div_hu_btr(iCell)
- hSum = hSum + zstarWeight(k)*h(k,iCell)
- end do
- if(hSum > 0.0) then
- h_tend_col = h_tend_col / hSum
- else
- end if
-
- ! Vertical velocity through layer interface at top and
- ! bottom is zero.
- wTop(1,iCell) = 0.0
- wTop(maxLevelCell(iCell)+1,iCell) = 0.0
- do k=maxLevelCell(iCell),2,-1
- wTop(k,iCell) = wTop(k+1,iCell) - div_hu(k,iCell) - h_tend_col(k)
- end do
- end do
-
- endif
-
- deallocate(div_hu, div_hu_btr, h_tend_col)
-
- end subroutine ocn_wtop!}}}
-
-!***********************************************************************
-!
-! routine ocn_fuperp
-!
-!> \brief Computes f u_perp
-!> \author Doug Jacobsen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes f u_perp for the ocean
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_fuperp(s, grid)!{{{
- implicit none
-
- type (state_type), intent(inout) :: s !< Input/Output: State information
- type (mesh_type), intent(in) :: grid !< Input: Grid information
-
-! mrp 110512 I just split compute_tend into compute_tend_u and compute_tend_h.
-! Some of these variables can be removed, but at a later time.
- integer :: iEdge, cell1, cell2, eoe, i, j, k
-
- integer :: nEdgesSolve
- real (kind=RKIND), dimension(:), pointer :: fEdge
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, u, uBcl
- type (dm_info) :: dminfo
-
- integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnEdge
- integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge
-
- call mpas_timer_start("ocn_fuperp")
-
- u => s % u % array
- uBcl => s % uBcl % array
- weightsOnEdge => grid % weightsOnEdge % array
- fEdge => grid % fEdge % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- cellsOnEdge => grid % cellsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- fEdge => grid % fEdge % array
-
- nEdgesSolve = grid % nEdgesSolve
-
- !
- ! Put f*uBcl^{perp} in u as a work variable
- !
- do iEdge=1,nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,maxLevelEdgeTop(iEdge)
-
- u(k,iEdge) = 0.0
- do j = 1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- u(k,iEdge) = u(k,iEdge) + weightsOnEdge(j,iEdge) * uBcl(k,eoe) * fEdge(eoe)
- end do
- end do
- end do
-
- call mpas_timer_stop("ocn_fuperp")
-
- end subroutine ocn_fuperp!}}}
-
-!***********************************************************************
-!
-! routine ocn_filter_btr_mode_u
-!
-!> \brief filters barotropic mode out of the velocity variable.
-!> \author Mark Petersen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine filters barotropic mode out of the velocity variable.
-!
-!-----------------------------------------------------------------------
- subroutine ocn_filter_btr_mode_u(s, grid)!{{{
- implicit none
-
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
-
- integer :: iEdge, k, nEdges
- real (kind=RKIND) :: vertSum, uhSum, hSum
- real (kind=RKIND), dimension(:,:), pointer :: h_edge, u
- integer, dimension(:), pointer :: maxLevelEdgeTop
-
- call mpas_timer_start("ocn_filter_btr_mode_u")
-
- u => s % u % array
- h_edge => s % h_edge % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- nEdges = grid % nEdges
-
- do iEdge=1,nEdges
-
- ! hSum is initialized outside the loop because on land boundaries
- ! maxLevelEdgeTop=0, but I want to initialize hSum with a
- ! nonzero value to avoid a NaN.
- uhSum = h_edge(1,iEdge) * u(1,iEdge)
- hSum = h_edge(1,iEdge)
-
- do k=2,maxLevelEdgeTop(iEdge)
- uhSum = uhSum + h_edge(k,iEdge) * u(k,iEdge)
- hSum = hSum + h_edge(k,iEdge)
- enddo
-
- vertSum = uhSum/hSum
- do k=1,maxLevelEdgeTop(iEdge)
- u(k,iEdge) = u(k,iEdge) - vertSum
- enddo
- enddo ! iEdge
-
- call mpas_timer_stop("ocn_filter_btr_mode_u")
-
- end subroutine ocn_filter_btr_mode_u!}}}
-
-!***********************************************************************
-!
-! routine ocn_filter_btr_mode_tend_u
-!
-!> \brief ocn_filters barotropic mode out of the u tendency
-!> \author Mark Petersen
-!> \date 23 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine filters barotropic mode out of the u tendency.
-!
-!-----------------------------------------------------------------------
- subroutine ocn_filter_btr_mode_tend_u(tend, s, grid)!{{{
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (mesh_type), intent(in) :: grid
-
- integer :: iEdge, k, nEdges
- real (kind=RKIND) :: vertSum, uhSum, hSum
- real (kind=RKIND), dimension(:,:), pointer :: h_edge, tend_u
-
- integer, dimension(:), pointer :: maxLevelEdgeTop
-
- call mpas_timer_start("ocn_filter_btr_mode_tend_u")
-
- tend_u => tend % u % array
- h_edge => s % h_edge % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- nEdges = grid % nEdges
-
- do iEdge=1,nEdges
-
- ! hSum is initialized outside the loop because on land boundaries
- ! maxLevelEdgeTop=0, but I want to initialize hSum with a
- ! nonzero value to avoid a NaN.
- uhSum = h_edge(1,iEdge) * tend_u(1,iEdge)
- hSum = h_edge(1,iEdge)
-
- do k=2,maxLevelEdgeTop(iEdge)
- uhSum = uhSum + h_edge(k,iEdge) * tend_u(k,iEdge)
- hSum = hSum + h_edge(k,iEdge)
- enddo
-
- vertSum = uhSum/hSum
- do k=1,maxLevelEdgeTop(iEdge)
- tend_u(k,iEdge) = tend_u(k,iEdge) - vertSum
- enddo
- enddo ! iEdge
-
- call mpas_timer_stop("ocn_filter_btr_mode_tend_u")
-
- end subroutine ocn_filter_btr_mode_tend_u!}}}
-
-!***********************************************************************
-!
! routine ocn_tendency_init
!
!> \brief Initializes flags used within tendency routines.
@@ -1162,49 +366,6 @@
err = 0
- coef_3rd_order = 0.
-
- if (config_thickness_adv_order == 2) then
- hadv2nd = 1
- hadv3rd = 0
- hadv4th = 0
- else if (config_thickness_adv_order == 3) then
- hadv2nd = 0
- hadv3rd = 1
- hadv4th = 0
-
- if(config_monotonic) then
- coef_3rd_order = 0.25
- else
- coef_3rd_order = 1.0
- endif
- else if (config_thickness_adv_order == 4) then
- hadv2nd = 0
- hadv3rd = 0
- hadv4th = 1
- end if
-
-
- if(config_include_KE_vertex) then
- ke_vertex_flag = 1
- ke_cell_flag = 0
- else
- ke_vertex_flag = 0
- ke_cell_flag = 1
- endif
-
- if (trim(config_time_integration) == 'RK4') then
- ! for RK4, PV is really PV = (eta+f)/h
- fCoef = 1
- elseif (trim(config_time_integration) == 'split_explicit' &
- .or.trim(config_time_integration) == 'unsplit_explicit') then
- ! for split explicit, PV is eta/h because f is added separately to the momentum forcing.
- ! mrp temp, new should be:
- fCoef = 0
- ! old, for testing:
- ! fCoef = 1
- end if
-
end subroutine ocn_tendency_init!}}}
!***********************************************************************
Deleted: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_test_cases.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_test_cases.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_test_cases.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,526 +0,0 @@
- module ocn_test_cases
-
- use mpas_grid_types
- use mpas_configure
- use mpas_constants
-
-
- contains
-
-
- subroutine setup_sw_test_case(domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Configure grid metadata and model state for the shallow water test case
- ! specified in the namelist
- !
- ! Output: block - a subset (not necessarily proper) of the model domain to be
- ! initialized
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- integer :: i, iCell, iEdge, iVtx, iLevel
- type (block_type), pointer :: block_ptr
- type (dm_info) :: dminfo
-
- if (config_test_case == 0) then
- write(0,*) 'Using initial conditions supplied in input file'
-
- else if (config_test_case == 1) then
- write(0,*) ' Setting up shallow water test case 1:'
- write(0,*) ' Advection of Cosine Bell over the Pole'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 2) then
- write(0,*) ' Setup shallow water test case 2: '// &
- 'Global Steady State Nonlinear Zonal Geostrophic Flow'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_2(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 5) then
- write(0,*) ' Setup shallow water test case 5:'// &
- ' Zonal Flow over an Isolated Mountain'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_5(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 6) then
- write(0,*) ' Set up shallow water test case 6:'
- write(0,*) ' Rossby-Haurwitz Wave'
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call sw_test_case_6(block_ptr % mesh, block_ptr % state % time_levs(1) % state)
- block_ptr => block_ptr % next
- end do
-
- else
- write(0,*) 'Abort: config_test_case=',config_test_case
- write(0,*) 'Only test case 1, 2, 5, and 6 ', &
- 'are currently supported. '
- call mpas_dmpar_abort(dminfo)
- end if
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
-
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, &
- block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- end subroutine setup_sw_test_case
-
-
- subroutine sw_test_case_1(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 1: Advection of Cosine Bell over the Pole
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- 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
- real (kind=RKIND), parameter :: theta_c = 0.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: alpha = pii/4.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: r, u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- 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
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Initialize cosine bell at (theta_c, lambda_c)
- !
- do iCell=1,grid % nCells
- r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
- if (r < a/3.0) then
- state % h % array(1,iCell) = (h0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
- else
- state % h % array(1,iCell) = 0.0
- end if
- end do
-
- end subroutine sw_test_case_1
-
-
- subroutine sw_test_case_2(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 2: Global Steady State Nonlinear Zonal
- ! Geostrophic Flow
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- 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
- real (kind=RKIND), parameter :: alpha = 0.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- 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
-
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha) &
- )
- end do
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) &
- )
- end do
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
- (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
- sin(grid%latCell%array(iCell)) * cos(alpha) &
- )**2.0 &
- ) / &
- gravity
- end do
-
- end subroutine sw_test_case_2
-
-
- subroutine sw_test_case_5(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 5: Zonal Flow over an Isolated Mountain
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- 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
-! real (kind=RKIND), parameter :: hs0 = 2000. original
- real (kind=RKIND), parameter :: hs0 = 250. !mrp 100204
- real (kind=RKIND), parameter :: theta_c = pii/6.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: rr = pii/9.0
- real (kind=RKIND), parameter :: alpha = 0.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: r, u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- 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
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * u0 * ( &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) - &
- cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) &
- )
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- (-cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha) &
- )
- end do
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha) &
- )
- end do
-
- !
- ! Initialize mountain
- !
- do iCell=1,grid % nCells
- if (grid % lonCell % array(iCell) < 0.0) grid % lonCell % array(iCell) = grid % lonCell % array(iCell) + 2.0 * pii
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
- grid % h_s % array(iCell) = hs0 * (1.0 - r/rr)
- end do
-! output about mountain
-print *, 'h_s',minval(grid % h_s % array),sum(grid % h_s % array)/grid % nCells, maxval(grid % h_s % array)
-
- !
- ! Initialize tracer fields
- !
- do iCell=1,grid % nCells
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + (grid % latCell % array(iCell) - theta_c)**2.0))
- state % tracers % array(1,1,iCell) = 1.0 - r/rr
- end do
- do iCell=1,grid % nCells
- r = sqrt(min(rr**2.0, (grid % lonCell % array(iCell) - lambda_c)**2.0 + &
- (grid % latCell % array(iCell) - theta_c - pii/6.0)**2.0 &
- ) &
- )
- state % tracers % array(2,1,iCell) = 1.0 - r/rr
- end do
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * &
- (-cos(grid%lonCell%array(iCell)) * cos(grid%latCell%array(iCell)) * sin(alpha) + &
- sin(grid%latCell%array(iCell)) * cos(alpha) &
- )**2.0 &
- ) / &
- gravity
- state % h % array(1,iCell) = state % h % array(1,iCell) - grid % h_s % array(iCell)
- end do
-
- end subroutine sw_test_case_5
-
-
- subroutine sw_test_case_6(grid, state)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup shallow water test case 6: Rossby-Haurwitz Wave
- !
- ! Reference: Williamson, D.L., et al., "A Standard Test Set for Numerical
- ! Approximations to the Shallow Water Equations in Spherical
- ! Geometry" J. of Comp. Phys., 102, pp. 211--224
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- 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
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- integer :: iCell, iEdge, iVtx
- real (kind=RKIND) :: u, v
- real (kind=RKIND), allocatable, dimension(:) :: psiVertex
-
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- 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
-
- !
- ! Initialize wind field
- !
- allocate(psiVertex(grid % nVertices))
- do iVtx=1,grid % nVertices
- psiVertex(iVtx) = -a * a * w * sin(grid%latVertex%array(iVtx)) + &
- a *a * K * (cos(grid%latVertex%array(iVtx))**R) * &
- sin(grid%latVertex%array(iVtx)) * cos(R * grid%lonVertex%array(iVtx))
- end do
- do iEdge=1,grid % nEdges
- state % u % array(1,iEdge) = -1.0 * ( &
- psiVertex(grid%verticesOnEdge%array(2,iEdge)) - &
- psiVertex(grid%verticesOnEdge%array(1,iEdge)) &
- ) / grid%dvEdge%array(iEdge)
- end do
- deallocate(psiVertex)
-
- !
- ! Initialize height field (actually, fluid thickness field)
- !
- do iCell=1,grid % nCells
- state % h % array(1,iCell) = (gravity * h0 + a*a*aa(grid%latCell%array(iCell)) + &
- 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
- end do
-
- end subroutine sw_test_case_6
-
-
- real function sphere_distance(lat1, lon1, lat2, lon2, radius)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
- ! sphere with given radius.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
-
- real (kind=RKIND) :: arg1
-
- arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
- cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
- sphere_distance = 2.*radius*asin(arg1)
-
- end function sphere_distance
-
-
- real function aa(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! A, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- aa = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
- 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*R**2*cos(theta)**(-2.0))
-
- end function aa
-
-
- real function bb(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! B, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- bb = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
-
- end function bb
-
-
- real function cc(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! C, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- cc = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
-
- end function cc
-
-end module ocn_test_cases
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_thick_hadv.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_thick_hadv.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_thick_hadv.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -41,8 +41,9 @@
! Private module variables
!
!--------------------------------------------------------------------
+
+ logical :: thickHadvOn
-
!***********************************************************************
contains
@@ -101,13 +102,13 @@
!
!-----------------------------------------------------------------
- integer :: iEdge, nEdges, cell1, cell2, nVertLevels, k
+ integer :: iEdge, nEdges, cell1, cell2, nVertLevels, k, i
integer :: iCell, nCells
- integer, dimension(:), pointer :: maxLevelEdgeBot, MaxLevelCell
- integer, dimension(:,:), pointer :: cellsOnEdge
+ integer, dimension(:), pointer :: maxLevelEdgeBot, MaxLevelCell, nEdgesOnCell
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, edgeSignOnCell
- real (kind=RKIND) :: flux, invAreaCell1, invAreaCell2
+ real (kind=RKIND) :: flux, invAreaCell, invAreaCell1, invAreaCell2
real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell
!-----------------------------------------------------------------
@@ -120,6 +121,8 @@
err = 0
+ if(.not.thickHadvOn) return
+
nEdges = grid % nEdges
nCells = grid % nCells
nVertLevels = grid % nVertLevels
@@ -130,20 +133,20 @@
dvEdge => grid % dvEdge % array
areaCell => grid % areaCell % array
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeBot(iEdge)
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
- tend(k,cell1) = tend(k,cell1) - flux
- tend(k,cell2) = tend(k,cell2) + flux
- end do
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
+
+ do iCell = 1, nCells
+ invAreaCell = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+ do k = 1, maxLevelEdgeBot(iEdge)
+ flux = u(k, iEdge) * dvEdge(iEdge) * h_edge(k, iEdge)
+ tend(k, iCell) = tend(k, iCell) + edgeSignOnCell(i, iCell) * flux * invAreaCell
+ end do
+ end do
end do
- do iCell=1,nCells
- do k=1,maxLevelCell(iCell)
- tend(k,iCell) = tend(k,iCell) / areaCell(iCell)
- end do
- end do
!--------------------------------------------------------------------
@@ -175,6 +178,10 @@
integer, intent(out) :: err !< Output: error flag
+ thickHadvOn = .true.
+
+ if(config_disable_h_hadv) thickHadvOn = .false.
+
err = 0
!--------------------------------------------------------------------
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_thick_vadv.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_thick_vadv.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_thick_vadv.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -42,6 +42,7 @@
!
!--------------------------------------------------------------------
+ logical :: thickVadvOn
!***********************************************************************
@@ -111,6 +112,8 @@
err = 0
+ if(.not.thickVadvOn) return
+
maxLevelCell => grid % maxLevelCell % array
nCells = grid % nCells
@@ -151,6 +154,10 @@
!-----------------------------------------------------------------
integer, intent(out) :: err !< Output: error flag
+
+ thickVadvOn = .true.
+
+ if(config_disable_h_vadv) thickVadvOn = .false.
err = 0
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_average.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_average.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_average.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -11,11 +11,11 @@
subroutine ocn_time_average_init(state)!{{{
type (state_type), intent(inout) :: state
- real, pointer :: nAccumulate
+ real (kind=RKIND), pointer :: nAccumulate
real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
- real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar, acc_vertVelocityTop
nAccumulate => state % nAccumulate % scalar
@@ -27,6 +27,7 @@
acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
acc_u => state % acc_u % array
acc_uVar => state % acc_uVar % array
+ acc_vertVelocityTop => state % acc_vertVelocityTop % array
nAccumulate = 0
@@ -38,6 +39,7 @@
acc_uReconstructMeridionalVar = 0.0
acc_u = 0.0
acc_uVar = 0.0
+ acc_vertVelocityTop = 0.0
end subroutine ocn_time_average_init!}}}
@@ -45,16 +47,16 @@
type (state_type), intent(inout) :: state
type (state_type), intent(in) :: old_state
- real, pointer :: nAccumulate, old_nAccumulate
+ real (kind=RKIND), pointer :: nAccumulate, old_nAccumulate
real (kind=RKIND), dimension(:), pointer :: ssh
- real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, u
+ real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, u, vertVelocityTop
- real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar, acc_vertVelocityTop
real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
- real (kind=RKIND), dimension(:,:), pointer :: old_acc_u, old_acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: old_acc_u, old_acc_uVar, old_acc_vertVelocityTop
real (kind=RKIND), dimension(:,:), pointer :: old_acc_uReconstructZonal, old_acc_uReconstructMeridional, old_acc_uReconstructZonalVar, old_acc_uReconstructMeridionalVar
real (kind=RKIND), dimension(:), pointer :: old_acc_ssh, old_acc_sshVar
@@ -65,6 +67,7 @@
uReconstructZonal => state % uReconstructZonal % array
uReconstructMeridional => state % uReconstructMeridional % array
u => state % u % array
+ vertVelocityTop => state % vertVelocityTop % array
acc_ssh => state % acc_ssh % array
acc_sshVar => state % acc_sshVar % array
@@ -74,6 +77,7 @@
acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
acc_u => state % acc_u % array
acc_uVar => state % acc_uVar % array
+ acc_vertVelocityTop => state % acc_vertVelocityTop % array
old_acc_ssh => old_state % acc_ssh % array
old_acc_sshVar => old_state % acc_sshVar % array
@@ -83,6 +87,7 @@
old_acc_uReconstructMeridionalVar => old_state % acc_uReconstructMeridionalVar % array
old_acc_u => old_state % acc_u % array
old_acc_uVar => old_state % acc_uVar % array
+ old_acc_vertVelocityTop => old_state % acc_vertVelocityTop % array
acc_ssh = old_acc_ssh + ssh
acc_sshVar = old_acc_sshVar + ssh**2
@@ -92,6 +97,7 @@
acc_uReconstructMeridionalVar = old_acc_uReconstructMeridionalVar + uReconstructMeridional**2
acc_u = old_acc_u + u
acc_uVar = old_acc_uVar + u**2
+ acc_vertVelocityTop = old_acc_vertVelocityTop + vertVelocityTop
nAccumulate = old_nAccumulate + 1
end subroutine ocn_time_average_accumulate!}}}
@@ -99,11 +105,11 @@
subroutine ocn_time_average_normalize(state)!{{{
type (state_type), intent(inout) :: state
- real, pointer :: nAccumulate
+ real (kind=RKIND), pointer :: nAccumulate
real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
- real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar, acc_vertVelocityTop
nAccumulate => state % nAccumulate % scalar
@@ -115,6 +121,7 @@
acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
acc_u => state % acc_u % array
acc_uVar => state % acc_uVar % array
+ acc_vertVelocityTop => state % acc_vertVelocityTop % array
if(nAccumulate > 0) then
acc_ssh = acc_ssh / nAccumulate
@@ -125,6 +132,7 @@
acc_uReconstructMeridionalVar = acc_uReconstructMeridionalVar / nAccumulate
acc_u = acc_u / nAccumulate
acc_uVar = acc_uVar / nAccumulate
+ acc_vertVelocityTop = acc_vertVelocityTop / nAccumulate
end if
end subroutine ocn_time_average_normalize!}}}
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -85,6 +85,8 @@
real (kind=RKIND), intent(in) :: dt
character(len=*), intent(in) :: timeStamp
+ real (kind=RKIND) :: nanCheck
+
type (dm_info) :: dminfo
type (block_type), pointer :: block
@@ -98,7 +100,9 @@
do while (associated(block))
block % state % time_levs(2) % state % xtime % scalar = timeStamp
- if (isNaN(sum(block % state % time_levs(2) % state % u % array))) then
+ nanCheck = sum(block % state % time_levs(2) % state % u % array)
+
+ if (nanCheck /= nanCheck) then
write(0,*) 'Abort: NaN detected'
call mpas_dmpar_abort(dminfo)
endif
@@ -117,14 +121,14 @@
rk4On = .false.
splitOn = .false.
- if (trim(config_time_integration) == 'RK4') then
+ if (trim(config_time_integrator) == 'RK4') then
rk4On = .true.
- elseif (trim(config_time_integration) == 'split_explicit' &
- .or.trim(config_time_integration) == 'unsplit_explicit') then
+ elseif (trim(config_time_integrator) == 'split_explicit' &
+ .or.trim(config_time_integrator) == 'unsplit_explicit') then
splitOn = .true.
else
err = 1
- write(*,*) 'Incorrect choice for config_time_integration:', trim(config_time_integration)
+ write(*,*) 'Incorrect choice for config_time_integrator:', trim(config_time_integrator)
write(*,*) ' choices are: RK4, split_explicit, unsplit_explicit'
endif
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration_rk4.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration_rk4.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration_rk4.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -22,6 +22,7 @@
use mpas_timer
use ocn_tendency
+ use ocn_diagnostics
use ocn_equation_of_state
use ocn_vmix
@@ -137,7 +138,7 @@
call mpas_timer_start("RK4-diagnostic halo update")
call mpas_dmpar_exch_halo_field(domain % blocklist % provis % Vor_edge)
- if (config_h_mom_eddy_visc4 > 0.0) then
+ if (config_mom_del4 > 0.0) then
call mpas_dmpar_exch_halo_field(domain % blocklist % provis % divergence)
call mpas_dmpar_exch_halo_field(domain % blocklist % provis % vorticity)
end if
@@ -148,23 +149,20 @@
call mpas_timer_start("RK4-tendency computations")
block => domain % blocklist
do while (associated(block))
+ ! advection of u uses u, while advection of h and tracers use uTransport.
+ call ocn_wtop(block % mesh, block % provis % h % array, block % provis % h_edge % array, &
+ block % provis % u % array, block % provis % wTop % array, err)
+ call ocn_tend_u(block % tend, block % provis, block % diagnostics, block % mesh)
- ! mrp 111206 put ocn_wtop call at top for ALE
- call ocn_wtop(block % provis, block % provis, block % mesh)
-
- if (.not.config_implicit_vertical_mix) then
- call ocn_vmix_coefs(block % mesh, block % provis, block % diagnostics, err)
- end if
+ call ocn_wtop(block % mesh, block % provis % h % array, block % provis % h_edge % array, &
+ block % provis % uTransport % array, block % provis % wTop % array, err)
call ocn_tend_h(block % tend, block % provis, block % mesh)
- call ocn_tend_u(block % tend, block % provis, block % diagnostics, block % mesh)
- ! mrp 110718 filter btr mode out of u_tend
- ! still got h perturbations with just this alone. Try to set uBtr=0 after full u computation
- if (config_rk_filter_btr_mode) then
+ if (config_filter_btr_mode) then
call ocn_filter_btr_mode_tend_u(block % tend, block % provis, block % mesh)
endif
- call ocn_tend_scalar(block % tend, block % provis, block % diagnostics, block % mesh, dt)
+ call ocn_tend_tracer(block % tend, block % provis, block % diagnostics, block % mesh, dt)
block => block % next
end do
call mpas_timer_stop("RK4-tendency computations")
@@ -198,10 +196,6 @@
end do
end do
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- end if
-
if (config_prescribe_velocity) then
block % provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
@@ -236,8 +230,8 @@
do iCell=1,block % mesh % nCells
do k=1,block % mesh % maxLevelCell % array(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)
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ + rk_weights(rk_step) * block % tend % tracers % array(:,k,iCell)
end do
end do
@@ -252,35 +246,51 @@
call mpas_timer_stop("RK4-main loop")
!
- ! A little clean up at the end: decouple new scalar fields and compute diagnostics for new state
+ ! A little clean up at the end: rescale tracer fields and compute diagnostics for new state
!
call mpas_timer_start("RK4-cleaup phase")
- if (config_implicit_vertical_mix) then
- call mpas_timer_start("RK4-implicit vert mix")
- block => domain % blocklist
- do while(associated(block))
- call ocn_vmix_implicit(dt, block % mesh, block % diagnostics, block % state % time_levs(2) % state, err)
- block => block % next
+
+ ! Rescale tracers
+ block => domain % blocklist
+ do while(associated(block))
+ do iCell = 1, block % mesh % nCells
+ do k = 1, block % mesh % maxLevelCell % array(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
+ block => block % next
+ end do
- ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done,
- ! this leads to lack of volume conservation. It is required because halo updates in RK4 are only
- ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to
- ! communicate the change due to implicit vertical mixing across the boundary.
- call mpas_timer_start("RK4-implicit vert mix halos")
- call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
- call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % tracers)
- call mpas_timer_stop("RK4-implicit vert mix halos")
+ call mpas_timer_start("RK4-implicit vert mix")
+ block => domain % blocklist
+ do while(associated(block))
- call mpas_timer_stop("RK4-implicit vert mix")
- end if
+ ! Call ocean diagnostic solve in preparation for vertical mixing. Note
+ ! it is called again after vertical mixing, because u and tracers change.
+ ! For Richardson vertical mixing, only rho, h_edge, and ke_edge need to
+ ! be computed. For kpp, more variables may be needed. Either way, this
+ ! could be made more efficient by only computing what is needed for the
+ ! implicit vmix routine that follows. mrp 121023.
+ call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
+ call ocn_vmix_implicit(dt, block % mesh, block % diagnostics, block % state % time_levs(2) % state, err)
+ block => block % next
+ end do
+
+ ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done,
+ ! this leads to lack of volume conservation. It is required because halo updates in RK4 are only
+ ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to
+ ! communicate the change due to implicit vertical mixing across the boundary.
+ call mpas_timer_start("RK4-implicit vert mix halos")
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % tracers)
+ call mpas_timer_stop("RK4-implicit vert mix halos")
+
+ call mpas_timer_stop("RK4-implicit vert mix")
+
block => domain % blocklist
do while (associated(block))
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- end if
-
if (config_prescribe_velocity) then
block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration_split.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration_split.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_time_integration_split.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -24,6 +24,7 @@
use mpas_timer
use ocn_tendency
+ use ocn_diagnostics
use ocn_equation_of_state
use ocn_vmix
@@ -86,9 +87,9 @@
type (dm_info) :: dminfo
integer :: iCell, i,k,j, iEdge, cell1, cell2, split_explicit_step, split, &
eoe, oldBtrSubcycleTime, newBtrSubcycleTime, uPerpTime, BtrCorIter, &
- n_bcl_iter(config_n_ts_iter)
+ n_bcl_iter(config_n_ts_iter), stage1_tend_time
type (block_type), pointer :: block
- real (kind=RKIND) :: uhSum, hSum, flux, sshEdge, &
+ real (kind=RKIND) :: uhSum, hSum, flux, sshEdge, hEdge1, &
CoriolisTerm, uCorr, temp, temp_h, coef, FBtr_coeff, sshCell1, sshCell2
integer :: num_tracers, ucorr_coef, err
real (kind=RKIND), dimension(:,:), pointer :: &
@@ -117,6 +118,9 @@
! The baroclinic velocity needs be recomputed at the beginning of a
! timestep because the implicit vertical mixing is conducted on the
! total u. We keep uBtr from the previous timestep.
+ ! Note that uBcl may now include a barotropic component, because the
+ ! weights h have changed. That is OK, because the GBtrForcing variable
+ ! subtracts out the barotropic component from the baroclinic.
block % state % time_levs(1) % state % uBcl % array(k,iEdge) &
= block % state % time_levs(1) % state % u % array(k,iEdge) &
- block % state % time_levs(1) % state % uBtr % array( iEdge)
@@ -164,7 +168,7 @@
call mpas_timer_start("se halo diag", .false., timer_halo_diagnostic)
call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % Vor_edge)
- if (config_h_mom_eddy_visc4 > 0.0) then
+ if (config_mom_del4 > 0.0) then
call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % divergence)
call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % vorticity)
end if
@@ -181,10 +185,18 @@
block => domain % blocklist
do while (associated(block))
- if (.not.config_implicit_vertical_mix) then
- call ocn_vmix_coefs(block % mesh, block % state % time_levs(2) % state, block % diagnostics, err)
- end if
- call ocn_tend_u(block % tend, block % state % time_levs(2) % state, block % diagnostics, block % mesh)
+
+ stage1_tend_time = min(split_explicit_step,2)
+
+ ! compute wTop. Use u (rather than uTransport) for momentum advection.
+ ! Use the most recent time level available.
+ call ocn_wtop(block % mesh, block % state % time_levs(stage1_tend_time) % state % h % array, &
+ block % state % time_levs(stage1_tend_time) % state % h_edge % array, &
+ block % state % time_levs(stage1_tend_time) % state % u % array, &
+ block % state % time_levs(stage1_tend_time) % state % wTop % array, err)
+
+ call ocn_tend_u(block % tend, block % state % time_levs(stage1_tend_time) % state, block % diagnostics, block % mesh)
+
block => block % next
end do
@@ -194,9 +206,9 @@
do j=1,n_bcl_iter(split_explicit_step)
! Use this G coefficient to avoid an if statement within the iEdge loop.
- if (trim(config_time_integration) == 'unsplit_explicit') then
+ if (trim(config_time_integrator) == 'unsplit_explicit') then
split = 0
- elseif (trim(config_time_integration) == 'split_explicit') then
+ elseif (trim(config_time_integrator) == 'split_explicit') then
split = 1
endif
@@ -246,6 +258,7 @@
= 0.5*( &
block % state % time_levs(1) % state % uBcl % array(k,iEdge) &
+ uTemp(k) - dt * block % state % time_levs(1) % state % GBtrForcing % array(iEdge))
+
enddo
enddo ! iEdge
@@ -278,7 +291,7 @@
oldBtrSubcycleTime = 1
newBtrSubcycleTime = 2
- if (trim(config_time_integration) == 'unsplit_explicit') then
+ if (trim(config_time_integrator) == 'unsplit_explicit') then
block => domain % blocklist
do while (associated(block))
@@ -305,7 +318,7 @@
block => block % next
end do ! block
- elseif (trim(config_time_integration) == 'split_explicit') then
+ elseif (trim(config_time_integrator) == 'split_explicit') then
! Initialize variables for barotropic subcycling
block => domain % blocklist
@@ -408,21 +421,63 @@
! config_btr_gam1_uWt1=0.5 flux = 1/2*(uBtrNew+uBtrOld)*H
! config_btr_gam1_uWt1= 0 flux = uBtrOld*H
! mrp 120201 efficiency: could we combine the following edge and cell loops?
+
+ do iCell = 1, block % mesh % nCells
+ do i = 1, block % mesh % nEdgesOnCell % array(iCell)
+ iEdge = block % mesh % edgesOnCell % array(i, iCell)
+
+ cell1 = block % mesh % cellsOnEdge % array(1, iEdge)
+ cell2 = block % mesh % cellsOnEdge % array(2, iEdge)
+
+ sshEdge = 0.5 * (block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
+ + block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) )
+
+ ! method 0: orig, works only without pbc:
+ !hSum = sshEdge + block % mesh % refBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1)
+
+ ! method 1, matches method 0 without pbcs, works with pbcs.
+ hSum = sshEdge + min(block % mesh % bottomDepth % array(cell1), &
+ block % mesh % bottomDepth % array(cell2))
+
+ ! method 2: may be better than method 1.
+ ! Take average of full thickness at two neighboring cells.
+ !hSum = sshEdge + 0.5 *( block % mesh % bottomDepth % array(cell1) &
+ ! + block % mesh % bottomDepth % array(cell2) )
+
+
+ flux = ((1.0-config_btr_gam1_uWt1) * block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ + config_btr_gam1_uWt1 * block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)) &
+ * hSum
+
+ block % tend % ssh % array(iCell) = block % tend % ssh % array(iCell) + block % mesh % edgeSignOncell % array(i, iCell) * flux &
+ * block % mesh % dvEdge % array(iEdge)
+
+ end do
+ end do
+
do iEdge=1,block % mesh % nEdges
cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
-
+
sshEdge = 0.5 * (block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
+ block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) )
- hSum = sshEdge + block % mesh % referenceBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1)
-
+
+ ! method 0: orig, works only without pbc:
+ !hSum = sshEdge + block % mesh % refBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1)
+
+ ! method 1, matches method 0 without pbcs, works with pbcs.
+ hSum = sshEdge + min(block % mesh % bottomDepth % array(cell1), &
+ block % mesh % bottomDepth % array(cell2))
+
+ ! method 2: may be better than method 1.
+ ! take average of full thickness at two neighboring cells
+ !hSum = sshEdge + 0.5 *( block % mesh % bottomDepth % array(cell1) &
+ ! + block % mesh % bottomDepth % array(cell2) )
+
flux = ((1.0-config_btr_gam1_uWt1) * block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ config_btr_gam1_uWt1 * block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)) &
* hSum
- block % tend % ssh % array(cell1) = block % tend % ssh % array(cell1) - flux * block % mesh % dvEdge % array(iEdge)
- block % tend % ssh % array(cell2) = block % tend % ssh % array(cell2) + flux * block % mesh % dvEdge % array(iEdge)
-
block % state % time_levs(1) % state % FBtr % array(iEdge) = block % state % time_levs(1) % state % FBtr % array(iEdge) &
+ FBtr_coeff*flux
end do
@@ -452,6 +507,8 @@
block => domain % blocklist
do while (associated(block))
+ allocate(utemp(block % mesh % nEdges+1))
+ uTemp(:) = block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:)
do iEdge=1,block % mesh % nEdges
cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
@@ -461,7 +518,8 @@
do i = 1,block % mesh % nEdgesOnEdge % array(iEdge)
eoe = block % mesh % edgesOnEdge % array(i,iEdge)
CoriolisTerm = CoriolisTerm + block % mesh % weightsOnEdge % array(i,iEdge) &
- * block % state % time_levs(uPerpTime) % state % uBtrSubcycle % array(eoe) &
+ !* block % state % time_levs(uPerpTime) % state % uBtrSubcycle % array(eoe) &
+ * uTemp(eoe) &
* block % mesh % fEdge % array(eoe)
end do
@@ -478,6 +536,7 @@
+ dt/config_n_btr_subcycles *(CoriolisTerm - gravity *(sshCell2 - sshCell1) /block % mesh % dcEdge % array(iEdge) &
+ block % state % time_levs(1) % state % GBtrForcing % array(iEdge))) * block % mesh % edgeMask % array(1,iEdge)
end do
+ deallocate(uTemp)
block => block % next
end do ! block
@@ -502,6 +561,45 @@
! config_btr_gam3_uWt2=0.5 flux = 1/2*(uBtrNew+uBtrOld)*H
! config_btr_gam3_uWt2= 0 flux = uBtrOld*H
! mrp 120201 efficiency: could we combine the following edge and cell loops?
+
+ do iCell = 1, block % mesh % nCells
+ do i = 1, block % mesh % nEdgesOnCell % array(iCell)
+ iEdge = block % mesh % edgesOnCell % array(i, iCell)
+
+ cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
+ cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+
+ ! SSH is a linear combination of SSHold and SSHnew.
+ sshCell1 = (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
+ + config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell1)
+ sshCell2 = (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) &
+ + config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell2)
+
+ sshEdge = 0.5 * (sshCell1 + sshCell2)
+
+ ! method 0: orig, works only without pbc:
+ !hSum = sshEdge + block % mesh % refBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1)
+
+ ! method 1, matches method 0 without pbcs, works with pbcs.
+ hSum = sshEdge + min(block % mesh % bottomDepth % array(cell1), &
+ block % mesh % bottomDepth % array(cell2))
+
+ ! method 2: may be better than method 1.
+ ! take average of full thickness at two neighboring cells
+ !hSum = sshEdge + 0.5 *( block % mesh % bottomDepth % array(cell1) &
+ ! + block % mesh % bottomDepth % array(cell2) )
+
+
+ flux = ((1.0-config_btr_gam3_uWt2) * block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ + config_btr_gam3_uWt2 * block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)) &
+ * hSum
+
+ block % tend % ssh % array(iCell) = block % tend % ssh % array(iCell) + block % mesh % edgeSignOnCell % array(i, iCell) * flux &
+ * block % mesh % dvEdge % array(iEdge)
+
+ end do
+ end do
+
do iEdge=1,block % mesh % nEdges
cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
@@ -511,17 +609,24 @@
+ config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell1)
sshCell2 = (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) &
+ config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell2)
+ sshEdge = 0.5 * (sshCell1 + sshCell2)
- sshEdge = 0.5 * (sshCell1 + sshCell2)
- hSum = sshEdge + block % mesh % referenceBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1)
+ ! method 0: orig, works only without pbc:
+ !hSum = sshEdge + block % mesh % refBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1)
+
+ ! method 1, matches method 0 without pbcs, works with pbcs.
+ hSum = sshEdge + min(block % mesh % bottomDepth % array(cell1), &
+ block % mesh % bottomDepth % array(cell2))
+
+ ! method 2, better, I think.
+ ! take average of full thickness at two neighboring cells
+ !hSum = sshEdge + 0.5 *( block % mesh % bottomDepth % array(cell1) &
+ ! + block % mesh % bottomDepth % array(cell2) )
flux = ((1.0-config_btr_gam3_uWt2) * block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ config_btr_gam3_uWt2 * block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)) &
* hSum
- block % tend % ssh % array(cell1) = block % tend % ssh % array(cell1) - flux * block % mesh % dvEdge % array(iEdge)
- block % tend % ssh % array(cell2) = block % tend % ssh % array(cell2) + flux * block % mesh % dvEdge % array(iEdge)
-
block % state % time_levs(1) % state % FBtr % array(iEdge) = block % state % time_levs(1) % state % FBtr % array(iEdge) + flux
end do
@@ -675,8 +780,14 @@
! dwj: 02/22/12 splitting thickness and tracer tendency computations and halo updates to allow monotonic advection.
block => domain % blocklist
do while (associated(block))
- call ocn_wtop(block % state % time_levs(1) % state,block % state % time_levs(2) % state, block % mesh)
+ ! compute wTop. Use uTransport for advection of h and tracers.
+ ! Use time level 1 values of h and h_edge because h has not yet been computed for time level 2.
+ call ocn_wtop(block % mesh, block % state % time_levs(1) % state % h % array, &
+ block % state % time_levs(1) % state % h_edge % array, &
+ block % state % time_levs(2) % state % uTransport % array, &
+ block % state % time_levs(2) % state % wTop % array, err)
+
call ocn_tend_h(block % tend, block % state % time_levs(2) % state, block % mesh)
block => block % next
end do
@@ -688,7 +799,7 @@
block => domain % blocklist
do while (associated(block))
- call ocn_tend_scalar(block % tend, block % state % time_levs(2) % state, block % diagnostics, block % mesh, dt)
+ call ocn_tend_tracer(block % tend, block % state % time_levs(2) % state, block % diagnostics, block % mesh, dt)
block => block % next
end do
@@ -825,33 +936,37 @@
! END large iteration loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- if (config_implicit_vertical_mix) then
- call mpas_timer_start("se implicit vert mix")
- block => domain % blocklist
- do while(associated(block))
- call ocn_vmix_implicit(dt, block % mesh, block % diagnostics, block % state % time_levs(2) % state, err)
- block => block % next
- end do
+ call mpas_timer_start("se implicit vert mix")
+ block => domain % blocklist
+ do while(associated(block))
- ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done,
- ! this leads to lack of volume conservation. It is required because halo updates in stage 3 are only
- ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to
- ! communicate the change due to implicit vertical mixing across the boundary.
- call mpas_timer_start("se implicit vert mix halos")
- call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
- call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % tracers)
- call mpas_timer_stop("se implicit vert mix halos")
+ ! Call ocean diagnostic solve in preparation for vertical mixing. Note
+ ! it is called again after vertical mixing, because u and tracers change.
+ ! For Richardson vertical mixing, only rho, h_edge, and ke_edge need to
+ ! be computed. For kpp, more variables may be needed. Either way, this
+ ! could be made more efficient by only computing what is needed for the
+ ! implicit vmix routine that follows. mrp 121023.
+ call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
- call mpas_timer_stop("se implicit vert mix")
- end if
+ call ocn_vmix_implicit(dt, block % mesh, block % diagnostics, block % state % time_levs(2) % state, err)
+ block => block % next
+ end do
+
+ ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done,
+ ! this leads to lack of volume conservation. It is required because halo updates in stage 3 are only
+ ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to
+ ! communicate the change due to implicit vertical mixing across the boundary.
+ call mpas_timer_start("se implicit vert mix halos")
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u)
+ call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % tracers)
+ call mpas_timer_stop("se implicit vert mix halos")
+
+ call mpas_timer_stop("se implicit vert mix")
+
block => domain % blocklist
do while (associated(block))
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- end if
-
if (config_prescribe_velocity) then
block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_advection.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_advection.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_advection.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -13,7 +13,7 @@
!
!-----------------------------------------------------------------------
-module mpas_ocn_tracer_advection
+module ocn_tracer_advection
use mpas_kind_types
use mpas_grid_types
@@ -21,9 +21,6 @@
use mpas_sort
use mpas_hash
-! use mpas_ocn_tracer_advection_std
-! use mpas_ocn_tracer_advection_mono
-
use mpas_tracer_advection_std
use mpas_tracer_advection_mono
@@ -31,16 +28,17 @@
private
save
- public :: mpas_ocn_tracer_advection_init, &
- mpas_ocn_tracer_advection_tend
+ public :: ocn_tracer_advection_init, &
+ ocn_tracer_advection_tend
+ logical :: tracerAdvOn
logical :: monotonicOn
contains
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
!
-! routine mpas_ocn_tracer_advection_tend
+! routine ocn_tracer_advection_tend
!
!> \brief MPAS ocean tracer advection tendency
!> \author Doug Jacobsen
@@ -51,7 +49,7 @@
!> advection of tracers.
!
!-----------------------------------------------------------------------
- subroutine mpas_ocn_tracer_advection_tend(tracers, uh, w, h, verticalCellSize, dt, grid, tend_h, tend)!{{{
+ subroutine ocn_tracer_advection_tend(tracers, uh, w, h, verticalCellSize, dt, grid, tend_h, tend)!{{{
real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: tracer tendency
real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input/Output: tracer values
@@ -63,16 +61,18 @@
type (mesh_type), intent(in) :: grid !< Input: grid information
real (kind=RKIND), dimension(:,:), intent(in) :: tend_h !< Input: Thickness tendency information
+ if(.not. tracerAdvOn) return
+
if(monotonicOn) then
call mpas_tracer_advection_mono_tend(tracers, uh, w, h, verticalCellSize, dt, grid, tend_h, tend, grid % maxLevelCell % array, grid % maxLevelEdgeTop % array, grid % highOrderAdvectionMask % array)
else
call mpas_tracer_advection_std_tend(tracers, uh, w, h, verticalCellSize, dt, grid, tend_h, tend, grid % maxLevelCell % array, grid % maxLevelEdgeTop % array, grid % highOrderAdvectionMask % array)
endif
- end subroutine mpas_ocn_tracer_advection_tend!}}}
+ end subroutine ocn_tracer_advection_tend!}}}
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
!
-! routine mpas_ocn_tracer_advection_init
+! routine ocn_tracer_advection_init
!
!> \brief MPAS ocean tracer advection tendency
!> \author Doug Jacobsen
@@ -83,7 +83,7 @@
!> the tracer advection routines.
!
!-----------------------------------------------------------------------
- subroutine mpas_ocn_tracer_advection_init(err)!{{{
+ subroutine ocn_tracer_advection_init(err)!{{{
integer, intent(inout) :: err !< Input/Output: Error flag
@@ -93,7 +93,6 @@
call mpas_tracer_advection_std_init(err_tmp)
call mpas_tracer_advection_mono_init(err_tmp)
-
err = ior(err, err_tmp)
monotonicOn = .false.
@@ -102,6 +101,6 @@
monotonicOn = .true.
endif
- end subroutine mpas_ocn_tracer_advection_init!}}}
+ end subroutine ocn_tracer_advection_init!}}}
-end module mpas_ocn_tracer_advection
+end module ocn_tracer_advection
Property changes on: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_advection.F
___________________________________________________________________
Added: svn:mergeinfo
## -0,0 +1,23 ##
+/branches/atmos_physics/src/core_ocean/mpas_ocn_tracer_advection.F:1672-1846
+/branches/cam_mpas_nh/src/core_ocean/mpas_ocn_tracer_advection.F:1260-1270
+/branches/ocean_projects/ale_split_exp/src/core_ocean/mpas_ocn_tracer_advection.F:1437-1483
+/branches/ocean_projects/ale_vert_coord/src/core_ocean/mpas_ocn_tracer_advection.F:1225-1383
+/branches/ocean_projects/ale_vert_coord_new/src/core_ocean/mpas_ocn_tracer_advection.F:1387-1428
+/branches/ocean_projects/gmvar/src/core_ocean/mpas_ocn_tracer_advection.F:1214-1514,1517-1738
+/branches/ocean_projects/imp_vert_mix_error/src/core_ocean/mpas_ocn_tracer_advection.F:1847-1887
+/branches/ocean_projects/imp_vert_mix_mrp/src/core_ocean/mpas_ocn_tracer_advection.F:754-986
+/branches/ocean_projects/monotonic_advection/src/core_ocean/mpas_ocn_tracer_advection.F:1499-1640
+/branches/ocean_projects/monthly_forcing/src/core_ocean/mpas_ocn_tracer_advection.F:1810-1867
+/branches/ocean_projects/split_explicit_mrp/src/core_ocean/mpas_ocn_tracer_advection.F:1134-1138
+/branches/ocean_projects/split_explicit_timestepping/src/core_ocean/mpas_ocn_tracer_advection.F:1044-1097
+/branches/ocean_projects/vert_adv_mrp/src/core_ocean/mpas_ocn_tracer_advection.F:704-745
+/branches/ocean_projects/vol_cons_RK_imp_mix/src/core_ocean/mpas_ocn_tracer_advection.F:1965-1992
+/branches/ocean_projects/zstar_restart_new/src/core_ocean/mpas_ocn_tracer_advection.F:1762-1770
+/branches/omp_blocks/block_decomp/src/core_ocean/mpas_ocn_tracer_advection.F:1374-1569
+/branches/omp_blocks/ddt_reorg/src/core_ocean/mpas_ocn_tracer_advection.F:1301-1414
+/branches/omp_blocks/halo/src/core_ocean/mpas_ocn_tracer_advection.F:1570-1638
+/branches/omp_blocks/io/src/core_ocean/mpas_ocn_tracer_advection.F:1639-1787
+/branches/omp_blocks/multiple_blocks/src/core_ocean/mpas_ocn_tracer_advection.F:1803-2084
+/branches/source_renaming/src/core_ocean/mpas_ocn_tracer_advection.F:1082-1113
+/branches/time_manager/src/core_ocean/mpas_ocn_tracer_advection.F:924-962
+/trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection.F:1641-1642,2091-2563
\ No newline at end of property
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -47,6 +47,7 @@
!
!--------------------------------------------------------------------
+ logical :: tracerHmixOn
type (timer_node), pointer :: del2Timer, del4Timer
@@ -122,6 +123,8 @@
!
!-----------------------------------------------------------------
+ if(.not.tracerHmixOn) return
+
call mpas_timer_start("del2", .false., del2Timer)
call ocn_tracer_hmix_del2_tend(grid, h_edge, tracers, tend, err1)
call mpas_timer_stop("del2", del2Timer)
@@ -165,6 +168,9 @@
integer :: err1, err2
+ tracerHmixOn = .true.
+
+ if(config_disable_tr_hmix) tracerHmixOn = .false.
call ocn_tracer_hmix_del2_init(err1)
call ocn_tracer_hmix_del4_init(err2)
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix_del2.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix_del2.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix_del2.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -107,13 +107,13 @@
!
!-----------------------------------------------------------------
- integer :: iEdge, nEdges, nVertLevels, cell1, cell2
- integer :: k, iTracer, num_tracers
+ integer :: iCell, iEdge, nCells, nEdges, nVertLevels, cell1, cell2
+ integer :: i, k, iTracer, num_tracers
integer, dimension(:,:), allocatable :: boundaryMask
- integer, dimension(:), pointer :: maxLevelEdgeTop
- integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask
+ integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnCell
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask, edgesOnCell, edgeSignOnCell
real (kind=RKIND) :: invAreaCell1, invAreaCell2
real (kind=RKIND) :: tracer_turb_flux, flux, r_tmp
@@ -134,6 +134,7 @@
if (.not.del2On) return
nEdges = grid % nEdges
+ nCells = grid % nCells
nVertLevels = grid % nVertLevels
num_tracers = size(tracers, dim=1)
@@ -145,31 +146,37 @@
dcEdge => grid % dcEdge % array
meshScalingDel2 => grid % meshScalingDel2 % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
+
!
! compute a boundary mask to enforce insulating boundary conditions in the horizontal
!
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- invAreaCell1 = 1.0/areaCell(cell1)
- invAreaCell2 = 1.0/areaCell(cell2)
+ do iCell = 1, nCells
+ invAreaCell1 = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOncell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
- r_tmp = meshScalingDel2(iEdge) * eddyDiff2 * dvEdge(iEdge) / dcEdge(iEdge)
-
- do k=1,maxLevelEdgeTop(iEdge)
- do iTracer=1,num_tracers
+ r_tmp = meshScalingDel2(iEdge) * eddyDiff2 * dvEdge(iEdge) / dcEdge(iEdge)
+
+ do k = 1, maxLevelEdgeTop(iEdge)
+ do iTracer = 1, num_tracers
! \kappa_2 </font>
<font color="red">abla \phi on edge
- tracer_turb_flux = tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)
+ tracer_turb_flux = tracers(iTracer, k, cell2) - tracers(iTracer, k, cell1)
! div(h \kappa_2 </font>
<font color="gray">abla \phi) at cell center
- flux = h_edge(k,iEdge) * tracer_turb_flux * edgeMask(k, iEdge) * r_tmp
+ flux = h_edge(k, iEdge) * tracer_turb_flux * edgeMask(k, iEdge) * r_tmp
- tend(iTracer,k,cell1) = tend(iTracer,k,cell1) + flux * invAreaCell1
- tend(iTracer,k,cell2) = tend(iTracer,k,cell2) - flux * invAreaCell2
- end do
- end do
+ tend(iTracer, k, iCell) = tend(iTracer, k, iCell) - edgeSignOnCell(i, iCell) * flux * invAreaCell1
+ end do
+ end do
+ end do
end do
+
!--------------------------------------------------------------------
end subroutine ocn_tracer_hmix_del2_tend!}}}
@@ -204,11 +211,13 @@
del2on = .false.
- if ( config_h_tracer_eddy_diff2 > 0.0 ) then
+ if ( config_tracer_del2 > 0.0 ) then
del2On = .true.
- eddyDiff2 = config_h_tracer_eddy_diff2
+ eddyDiff2 = config_tracer_del2
endif
+ if(.not.config_use_tracer_del2) del2on = .false.
+
!--------------------------------------------------------------------
end subroutine ocn_tracer_hmix_del2_init!}}}
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix_del4.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix_del4.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_tracer_hmix_del4.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -108,10 +108,10 @@
!-----------------------------------------------------------------
integer :: iEdge, nEdges, num_tracers, nVertLevels, nCells
- integer :: iTracer, k, iCell, cell1, cell2
+ integer :: iTracer, k, iCell, cell1, cell2, i
- integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelCell
- integer, dimension(:,:), pointer :: edgeMask, cellsOnEdge
+ integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelCell, nEdgesOnCell
+ integer, dimension(:,:), pointer :: edgeMask, cellsOnEdge, edgesOnCell, edgeSignOnCell
real (kind=RKIND) :: invAreaCell1, invAreaCell2, tracer_turb_flux, flux, invdcEdge, r_tmp1, r_tmp2
@@ -148,56 +148,55 @@
edgeMask => grid % edgeMask % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
+
allocate(delsq_tracer(num_tracers,nVertLevels, nCells+1))
delsq_tracer(:,:,:) = 0.0
! first del2: div(h </font>
<font color="red">abla \phi) at cell center
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
+ do iCell = 1, nCells
+ invAreaCell1 = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+ invdcEdge = dvEdge(iEdge) / dcEdge(iEdge)
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
- invdcEdge = 1.0 / dcEdge(iEdge)
+ do k = 1, maxLevelEdgeTop(iEdge)
+ do iTracer = 1, num_tracers * edgeMask(k, iEdge)
- invAreaCell1 = 1.0 / areaCell(cell1)
- invAreaCell2 = 1.0 / areaCell(cell2)
+ r_tmp1 = invdcEdge * h_edge(k, iEdge) * tracers(iTracer, k, cell1)
+ r_tmp2 = invdcEdge * h_edge(k, iEdge) * tracers(iTracer, k, cell2)
- do k=1,maxLevelEdgeTop(iEdge)
- do iTracer=1,num_tracers * edgeMask(k, iEdge)
-
- r_tmp1 = dvEdge(iEdge) * h_edge(k,iEdge) * invdcEdge
-
- r_tmp2 = r_tmp1 * tracers(iTracer,k,cell2)
- r_tmp1 = r_tmp1 * tracers(iTracer,k,cell1)
-
- delsq_tracer(iTracer,k,cell1) = delsq_tracer(iTracer,k,cell1) + (r_tmp2 - r_tmp1) * invAreaCell1
- delsq_tracer(iTracer,k,cell2) = delsq_tracer(iTracer,k,cell2) - (r_tmp2 - r_tmp1) * invAreaCell2
- end do
- end do
+ delsq_tracer(iTracer, k, iCell) = delsq_tracer(iTracer, k, iCell) - edgeSignOnCell(i, iCell) * (r_tmp2 - r_tmp1) * invAreaCell1
+ end do
+ end do
+ end do
end do
! second del2: div(h </font>
<font color="gray">abla [delsq_tracer]) at cell center
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
+ do iCell = 1, nCells
+ invAreaCell1 = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+ cell1 = cellsOnEdge(1, iEdge)
+ cell2 = cellsOnedge(2, iEdge)
- invAreaCell1 = 1.0 / areaCell(cell1)
- invAreaCell2 = 1.0 / areaCell(cell2)
+ invdcEdge = meshScalingDel4(iEdge) * dvEdge(iEdge) * eddyDiff4 / dcEdge(iEdge)
- invdcEdge = 1.0 / dcEdge(iEdge)
+ do k = 1, maxLevelEdgeTop(iEdge)
+ do iTracer = 1, num_tracers * edgeMask(k, iEdge)
+ tracer_turb_flux = (delsq_tracer(iTracer, k, cell2) - delsq_tracer(iTracer, k, cell1))
+
+ flux = tracer_turb_flux * invdcEdge
- do k=1,maxLevelEdgeTop(iEdge)
- do iTracer=1,num_tracers * edgeMask(k,iEdge)
- tracer_turb_flux = meshScalingDel4(iEdge) * eddyDiff4 &
- * (delsq_tracer(iTracer,k,cell2) - delsq_tracer(iTracer,k,cell1)) &
- * invdcEdge
-
- flux = dvEdge (iEdge) * tracer_turb_flux
-
- tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - flux * invAreaCell1
- tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + flux * invAreaCell2
- enddo
- enddo
+ tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + edgeSignOnCell(i, iCell) * flux * invAreaCell1
+ end do
+ end do
+ end do
end do
deallocate(delsq_tracer)
@@ -234,11 +233,13 @@
err = 0
del4on = .false.
- if ( config_h_tracer_eddy_diff4 > 0.0 ) then
+ if ( config_tracer_del4 > 0.0 ) then
del4On = .true.
- eddyDiff4 = config_h_tracer_eddy_diff4
+ eddyDiff4 = config_tracer_del4
endif
+ if(.not.config_use_tracer_del4) del4on = .false.
+
!--------------------------------------------------------------------
end subroutine ocn_tracer_hmix_del4_init!}}}
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_coriolis.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_coriolis.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_coriolis.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -43,6 +43,7 @@
!
!--------------------------------------------------------------------
+ logical :: coriolisOn
!***********************************************************************
@@ -116,6 +117,8 @@
err = 0
+ if(.not.coriolisOn) return
+
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
nEdgesOnEdge => grid % nEdgesOnEdge % array
cellsOnEdge => grid % cellsOnEdge % array
@@ -181,6 +184,10 @@
err = 0
+ coriolisOn = .true.
+
+ if(config_disable_u_coriolis) coriolisOn = .false.
+
!--------------------------------------------------------------------
end subroutine ocn_vel_coriolis_init!}}}
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -18,7 +18,6 @@
use mpas_configure
use ocn_vel_forcing_windstress
- use ocn_vel_forcing_bottomdrag
use ocn_vel_forcing_rayleigh
implicit none
@@ -115,7 +114,7 @@
!
!-----------------------------------------------------------------
- integer :: err1, err2, err3
+ integer :: err1, err2
!-----------------------------------------------------------------
!
@@ -126,11 +125,9 @@
!-----------------------------------------------------------------
call ocn_vel_forcing_windstress_tend(grid, u_src, h_edge, tend, err1)
- call ocn_vel_forcing_bottomdrag_tend(grid, u, ke_edge, h_edge, tend, err2)
- call ocn_vel_forcing_rayleigh_tend(grid, u, tend, err3)
+ call ocn_vel_forcing_rayleigh_tend(grid, u, tend, err2)
err = ior(err1, err2)
- err = ior(err, err3)
!--------------------------------------------------------------------
@@ -164,14 +161,12 @@
integer, intent(out) :: err !< Output: error flag
- integer :: err1, err2, err3
+ integer :: err1, err2
call ocn_vel_forcing_windstress_init(err1)
- call ocn_vel_forcing_bottomdrag_init(err2)
- call ocn_vel_forcing_rayleigh_init(err3)
+ call ocn_vel_forcing_rayleigh_init(err2)
err = ior(err1, err2)
- err = ior(err, err3)
!--------------------------------------------------------------------
Deleted: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,193 +0,0 @@
-!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
-!
-! ocn_vel_forcing_bottomdrag
-!
-!> \brief MPAS ocean bottom drag
-!> \author Doug Jacobsen
-!> \date 16 September 2011
-!> \version SVN:$Id:$
-!> \details
-!> This module contains the routine for computing
-!> tendencies from bottom drag.
-!
-!-----------------------------------------------------------------------
-
-module ocn_vel_forcing_bottomdrag
-
- use mpas_grid_types
- use mpas_configure
-
- implicit none
- private
- save
-
- !--------------------------------------------------------------------
- !
- ! Public parameters
- !
- !--------------------------------------------------------------------
-
- !--------------------------------------------------------------------
- !
- ! Public member functions
- !
- !--------------------------------------------------------------------
-
- public :: ocn_vel_forcing_bottomdrag_tend, &
- ocn_vel_forcing_bottomdrag_init
-
- !--------------------------------------------------------------------
- !
- ! Private module variables
- !
- !--------------------------------------------------------------------
-
- logical :: bottomDragOn
- real (kind=RKIND) :: bottomDragCoef
-
-
-!***********************************************************************
-
-contains
-
-!***********************************************************************
-!
-! routine ocn_vel_forcing_bottomdrag_tend
-!
-!> \brief Computes tendency term from bottom drag
-!> \author Doug Jacobsen
-!> \date 15 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the bottom drag tendency for momentum
-!> based on current state.
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_vel_forcing_bottomdrag_tend(grid, u, ke_edge, h_edge, tend, err)!{{{
-
- !-----------------------------------------------------------------
- !
- ! input variables
- !
- !-----------------------------------------------------------------
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- u !< Input: velocity
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- ke_edge !< Input: kinetic energy at edge
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- h_edge !< Input: thickness at edge
-
- type (mesh_type), intent(in) :: &
- grid !< Input: grid information
-
- !-----------------------------------------------------------------
- !
- ! input/output variables
- !
- !-----------------------------------------------------------------
-
- real (kind=RKIND), dimension(:,:), intent(inout) :: &
- tend !< Input/Output: velocity tendency
-
- !-----------------------------------------------------------------
- !
- ! output variables
- !
- !-----------------------------------------------------------------
-
- integer, intent(out) :: err !< Output: error flag
-
- !-----------------------------------------------------------------
- !
- ! local variables
- !
- !-----------------------------------------------------------------
-
- integer :: iEdge, nEdgesSolve, k
- integer, dimension(:), pointer :: maxLevelEdgeTop
- integer, dimension(:,:), pointer :: edgeMask
-
- !-----------------------------------------------------------------
- !
- ! call relevant routines for computing tendencies
- ! note that the user can choose multiple options and the
- ! tendencies will be added together
- !
- !-----------------------------------------------------------------
-
- err = 0
-
- if(.not.bottomDragOn) return
-
- nEdgesSolve = grid % nEdgesSolve
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- edgeMask => grid % edgeMask % array
-
- do iEdge=1,grid % nEdgesSolve
-
- k = max(maxLevelEdgeTop(iEdge), 1)
-
- ! bottom drag is the same as POP:
- ! -c |u| u where c is unitless and 1.0e-3.
- ! see POP Reference guide, section 3.4.4.
-
- tend(k,iEdge) = tend(k,iEdge)-edgeMask(k,iEdge)*(bottomDragCoef*u(k,iEdge)*sqrt(2.0*ke_edge(k,iEdge))/h_edge(k,iEdge))
-
- enddo
-
-
-
- !--------------------------------------------------------------------
-
- end subroutine ocn_vel_forcing_bottomdrag_tend!}}}
-
-!***********************************************************************
-!
-! routine ocn_vel_forcing_bottomdrag_init
-!
-!> \brief Initializes ocean bottom drag
-!> \author Doug Jacobsen
-!> \date 16 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine initializes quantities related to bottom drag
-!> in the ocean.
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_vel_forcing_bottomdrag_init(err)!{{{
-
- !--------------------------------------------------------------------
-
- !-----------------------------------------------------------------
- !
- ! call individual init routines for each parameterization
- !
- !-----------------------------------------------------------------
-
- integer, intent(out) :: err !< Output: error flag
-
-
- err = 0
-
- bottomDragOn = .false.
-
- if (.not.config_implicit_vertical_mix) then
- bottomDragOn = .true.
- bottomDragCoef = config_bottom_drag_coeff
- endif
-
- !--------------------------------------------------------------------
-
- end subroutine ocn_vel_forcing_bottomdrag_init!}}}
-
-!***********************************************************************
-
-end module ocn_vel_forcing_bottomdrag
-
-!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
-! vim: foldmethod=marker
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing_windstress.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing_windstress.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_forcing_windstress.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -168,6 +168,8 @@
windStressOn = .true.
+ if(config_disable_u_windstress) windStressOn = .false.
+
err = 0
!--------------------------------------------------------------------
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -20,6 +20,7 @@
use mpas_configure
use mpas_timer
use ocn_vel_hmix_del2
+ use ocn_vel_hmix_leith
use ocn_vel_hmix_del4
implicit none
@@ -47,7 +48,8 @@
!
!--------------------------------------------------------------------
- type (timer_node), pointer :: del2Timer, del4Timer
+ logical :: hmixOn
+ type (timer_node), pointer :: del2Timer, leithTimer, del4Timer
!***********************************************************************
@@ -72,7 +74,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_vel_hmix_tend(grid, divergence, vorticity, tend, err)!{{{
+ subroutine ocn_vel_hmix_tend(grid, divergence, vorticity, viscosity, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -98,6 +100,9 @@
real (kind=RKIND), dimension(:,:), intent(inout) :: &
tend !< Input/Output: velocity tendency
+ real (kind=RKIND), dimension(:,:), intent(inout) :: &
+ viscosity !< Input: viscosity
+
!-----------------------------------------------------------------
!
! output variables
@@ -112,7 +117,7 @@
!
!-----------------------------------------------------------------
- integer :: err1, err2
+ integer :: err1, err2, err3
!-----------------------------------------------------------------
!
@@ -122,14 +127,23 @@
!
!-----------------------------------------------------------------
+ if(.not.hmixOn) return
+
+ viscosity = 0.0
+
call mpas_timer_start("del2", .false., del2Timer)
- call ocn_vel_hmix_del2_tend(grid, divergence, vorticity, tend, err1)
+ call ocn_vel_hmix_del2_tend(grid, divergence, vorticity, viscosity, tend, err1)
call mpas_timer_stop("del2", del2Timer)
+
+ call mpas_timer_start("leith", .false., leithTimer)
+ call ocn_vel_hmix_leith_tend(grid, divergence, vorticity, viscosity, tend, err2)
+ call mpas_timer_stop("leith", leithTimer)
+
call mpas_timer_start("del4", .false., del4Timer)
- call ocn_vel_hmix_del4_tend(grid, divergence, vorticity, tend, err2)
+ call ocn_vel_hmix_del4_tend(grid, divergence, vorticity, tend, err3)
call mpas_timer_stop("del4", del4Timer)
- err = ior(err1, err2)
+ err = ior(ior(err1, err2),err3)
!--------------------------------------------------------------------
@@ -163,13 +177,18 @@
integer, intent(out) :: err !< Output: error flag
- integer :: err1, err2
+ integer :: err1, err2, err3
+ hmixOn = .true.
+
call ocn_vel_hmix_del2_init(err1)
- call ocn_vel_hmix_del4_init(err2)
+ call ocn_vel_hmix_leith_init(err2)
+ call ocn_vel_hmix_del4_init(err3)
- err = ior(err1, err2)
+ err = ior(ior(err1, err2),err3)
+ if(config_disable_u_hmix) hmixOn = .false.
+
!--------------------------------------------------------------------
end subroutine ocn_vel_hmix_init!}}}
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_del2.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_del2.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_del2.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -70,7 +70,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_vel_hmix_del2_tend(grid, divergence, vorticity, tend, err)!{{{
+ subroutine ocn_vel_hmix_del2_tend(grid, divergence, vorticity, viscosity, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -96,6 +96,8 @@
real (kind=RKIND), dimension(:,:), intent(inout) :: &
tend !< Input/Output: velocity tendency
+ real (kind=RKIND), dimension(:,:), intent(inout) :: &
+ viscosity !< Input: viscosity
!-----------------------------------------------------------------
!
@@ -111,12 +113,11 @@
!
!-----------------------------------------------------------------
- integer :: iEdge, nEdgesSolve, cell1, cell2, vertex1, vertex2
- integer :: k
+ integer :: iEdge, nEdgesSolve, cell1, cell2, vertex1, vertex2, k
integer, dimension(:), pointer :: maxLevelEdgeTop
integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask
- real (kind=RKIND) :: u_diffusion, invLength1, invLength2
+ real (kind=RKIND) :: u_diffusion, invLength1, invLength2, visc2
real (kind=RKIND), dimension(:), pointer :: meshScalingDel2, &
dcEdge, dvEdge
@@ -158,10 +159,12 @@
-viscVortCoef &
*( vorticity(k,vertex2) - vorticity(k,vertex1) ) * invLength2
- u_diffusion = meshScalingDel2(iEdge) * eddyVisc2 * u_diffusion
+ visc2 = meshScalingDel2(iEdge) * eddyVisc2
- tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * u_diffusion
+ tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * visc2 * u_diffusion
+ viscosity(k,iEdge) = viscosity(k,iEdge) + visc2
+
end do
end do
@@ -198,19 +201,20 @@
hmixDel2On = .false.
- if ( config_h_mom_eddy_visc2 > 0.0 ) then
+ if ( config_mom_del2 > 0.0 ) then
hmixDel2On = .true.
- eddyVisc2 = config_h_mom_eddy_visc2
+ eddyVisc2 = config_mom_del2
-
if (config_visc_vorticity_term) then
- viscVortCoef = config_visc_vorticity_visc2_scale
+ viscVortCoef = config_vorticity_del2_scale
else
viscVortCoef = 0.0
endif
endif
+ if(.not.config_use_mom_del2) hmixDel2On = .false.
+
!--------------------------------------------------------------------
end subroutine ocn_vel_hmix_del2_init!}}}
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_del4.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -112,22 +112,22 @@
!
!-----------------------------------------------------------------
- integer :: iEdge, cell1, cell2, vertex1, vertex2, k
+ integer :: iEdge, cell1, cell2, vertex1, vertex2, k, i
integer :: iCell, iVertex
- integer :: nVertices, nVertLevels, nCells, nEdges, nEdgesSolve
+ integer :: nVertices, nVertLevels, nCells, nEdges, nEdgesSolve, vertexDegree
- integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelVertexBot, &
- maxLevelCell
- integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask
+ integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelVertexTop, &
+ maxLevelCell, nEdgesOnCell
+ integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask, edgesOnVertex, edgesOnCell, edgeSignOnVertex, edgeSignOnCell
real (kind=RKIND) :: u_diffusion, invAreaCell1, invAreaCell2, invAreaTri1, &
- invAreaTri2, invDcEdge, invDvEdge, r_tmp, delsq_u
+ invAreaTri2, invDcEdge, invDvEdge, r_tmp
real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaTriangle, &
meshScalingDel4, areaCell
real (kind=RKIND), dimension(:,:), allocatable :: delsq_divergence, &
- delsq_circulation, delsq_vorticity
+ delsq_circulation, delsq_vorticity, delsq_u
err = 0
@@ -138,8 +138,10 @@
nEdgesSolve = grid % nEdgessolve
nVertices = grid % nVertices
nVertLevels = grid % nVertLevels
+ vertexDegree = grid % vertexDegree
+
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
+ maxLevelVertexTop => grid % maxLevelVertexTop % array
maxLevelCell => grid % maxLevelCell % array
cellsOnEdge => grid % cellsOnEdge % array
verticesOnEdge => grid % verticesOnEdge % array
@@ -149,43 +151,57 @@
areaCell => grid % areaCell % array
meshScalingDel4 => grid % meshScalingDel4 % array
edgeMask => grid % edgeMask % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgeSignOnVertex => grid % edgeSignOnVertex % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
+ allocate(delsq_u(nVertLEvels, nEdges+1))
allocate(delsq_divergence(nVertLevels, nCells+1))
allocate(delsq_vorticity(nVertLevels, nVertices+1))
+ delsq_u(:,:) = 0.0
delsq_vorticity(:,:) = 0.0
delsq_divergence(:,:) = 0.0
- do iEdge=1,nEdges
+ !Compute delsq_u
+ do iEdge = 1, nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
vertex1 = verticesOnEdge(1,iEdge)
vertex2 = verticesOnEdge(2,iEdge)
- invAreaTri1 = 1.0 / areaTriangle(vertex1)
- invAreaTri2 = 1.0 / areaTriangle(vertex2)
-
- invAreaCell1 = 1.0 / areaCell(cell1)
- invAreaCell2 = 1.0 / areaCell(cell2)
-
invDcEdge = 1.0 / dcEdge(iEdge)
invDvEdge = 1.0 / dvEdge(iEdge)
do k=1,maxLevelEdgeTop(iEdge)
! Compute </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="red">abla vorticity
- delsq_u = ( divergence(k,cell2) - divergence(k,cell1) ) * invDcEdge &
+ delsq_u(k, iEdge) = ( divergence(k,cell2) - divergence(k,cell1) ) * invDcEdge &
-viscVortCoef *( vorticity(k,vertex2) - vorticity(k,vertex1)) * invDcEdge * sqrt(3.0) ! TDR
+ end do
+ end do
- ! vorticity using </font>
<font color="red">abla^2 u
- r_tmp = dcEdge(iEdge) * delsq_u
- delsq_vorticity(k,vertex1) = delsq_vorticity(k,vertex1) - r_tmp * invAreaTri1
- delsq_vorticity(k,vertex2) = delsq_vorticity(k,vertex2) + r_tmp * invAreaTri2
+ ! Compute delsq_vorticity
+ do iVertex = 1, nVertices
+ invAreaTri1 = 1.0 / areaTriangle(iVertex)
+ do i = 1, vertexDegree
+ iEdge = edgesOnVertex(i, iVertex)
+ do k = 1, maxLevelVertexTop(iVertex)
+ delsq_vorticity(k, iVertex) = delsq_vorticity(k, iVertex) + edgeSignOnVertex(i, iVertex) * dcEdge(iEdge) * delsq_u(k, iEdge) * invAreaTri1
+ end do
+ end do
+ end do
- ! Divergence using </font>
<font color="gray">abla^2 u
- r_tmp = dvEdge(iEdge) * delsq_u
- delsq_divergence(k, cell1) = delsq_divergence(k,cell1) + r_tmp * invAreaCell1
- delsq_divergence(k, cell2) = delsq_divergence(k,cell2) - r_tmp * invAreaCell2
+ ! Compute delsq_divergence
+ do iCell = 1, nCells
+ invAreaCell1 = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+ do k = 1, maxLevelCell(iCell)
+ delsq_divergence(k, iCell) = delsq_divergence(k, iCell) - edgeSignOnCell(i, iCell) * dvEdge(iEdge) * delsq_u(k, iEdge) * invAreaCell1
+ end do
end do
end do
@@ -209,6 +225,7 @@
end do
end do
+ deallocate(delsq_u)
deallocate(delsq_divergence)
deallocate(delsq_vorticity)
@@ -244,17 +261,19 @@
hmixDel4On = .false.
- if ( config_h_mom_eddy_visc4 > 0.0 ) then
+ if ( config_mom_del4 > 0.0 ) then
hmixDel4On = .true.
- eddyVisc4 = config_h_mom_eddy_visc4
+ eddyVisc4 = config_mom_del4
if (config_visc_vorticity_term) then
- viscVortCoef = config_visc_vorticity_visc4_scale
+ viscVortCoef = config_vorticity_del4_scale
else
viscVortCoef = 0.0
endif
endif
+ if(.not.config_use_mom_del4) hmixDel4On = .false.
+
!--------------------------------------------------------------------
end subroutine ocn_vel_hmix_del4_init!}}}
Copied: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_leith.F (from rev 2563, trunk/mpas/src/core_ocean/mpas_ocn_vel_hmix_leith.F)
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_leith.F (rev 0)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_hmix_leith.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -0,0 +1,235 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_vel_hmix_leith
+!
+!> \brief Ocean horizontal mixing - Leith parameterization
+!> \author Mark Petersen
+!> \date 22 October 2012
+!> \version SVN:$Id:$
+!> \details
+!> This module contains routines for computing horizontal mixing
+!> tendencies using the Leith parameterization.
+!
+!-----------------------------------------------------------------------
+
+module ocn_vel_hmix_leith
+
+ use mpas_grid_types
+ use mpas_configure
+
+ implicit none
+ private
+ save
+
+ !--------------------------------------------------------------------
+ !
+ ! Public parameters
+ !
+ !--------------------------------------------------------------------
+
+ !--------------------------------------------------------------------
+ !
+ ! Public member functions
+ !
+ !--------------------------------------------------------------------
+
+ public :: ocn_vel_hmix_leith_tend, &
+ ocn_vel_hmix_leith_init
+
+ !-------------------------------------------------------------------
+ !
+ ! Private module variables
+ !
+ !--------------------------------------------------------------------
+
+ logical :: hmixLeithOn !< integer flag to determine whether leith chosen
+
+ real (kind=RKIND) :: &
+ viscVortCoef
+
+!***********************************************************************
+
+contains
+
+!***********************************************************************
+!
+! routine ocn_vel_hmix_leith_tend
+!
+!> \brief Computes tendency term for horizontal momentum mixing with Leith parameterization
+!> \author Mark Petersen, Todd Ringler
+!> \date 22 October 2012
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the horizontal mixing tendency for momentum
+!> based on the Leith closure. The Leith closure is the
+!> enstrophy-cascade analogy to the Smagorinsky (1963) energy-cascade
+!> closure, i.e. Leith (1996) assumes an inertial range of enstrophy flux
+!> moving toward the grid scale. The assumption of an enstrophy cascade
+!> and dimensional analysis produces right-hand-side dissipation,
+!> $\bf{D}$, of velocity of the form
+!> $ {\bf D} = </font>
<font color="black">abla \cdot \left( </font>
<font color="black">u_\ast </font>
<font color="blue">abla {\bf u} \right)
+!> = </font>
<font color="black">abla \cdot \left( \gamma \left| </font>
<font color="blue">abla \omega \right|
+!> \left( \Delta x \right)^3 </font>
<font color="blue">abla \bf{u} \right)
+!> where $\omega$ is the relative vorticity and $\gamma$ is a non-dimensional,
+!> $O(1)$ parameter. We set $\gamma=1$.
+
+!
+!-----------------------------------------------------------------------
+
+ subroutine ocn_vel_hmix_leith_tend(grid, divergence, vorticity, viscosity, tend, err)!{{{
+
+ !-----------------------------------------------------------------
+ !
+ ! input variables
+ !
+ !-----------------------------------------------------------------
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ divergence !< Input: velocity divergence
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ vorticity !< Input: vorticity
+
+ type (mesh_type), intent(in) :: &
+ grid !< Input: grid information
+
+ !-----------------------------------------------------------------
+ !
+ ! input/output variables
+ !
+ !-----------------------------------------------------------------
+
+ real (kind=RKIND), dimension(:,:), intent(inout) :: &
+ tend !< Input/Output: velocity tendency
+
+ real (kind=RKIND), dimension(:,:), intent(inout) :: &
+ viscosity !< Input: viscosity
+
+ !-----------------------------------------------------------------
+ !
+ ! output variables
+ !
+ !-----------------------------------------------------------------
+
+ integer, intent(out) :: err !< Output: error flag
+
+ !-----------------------------------------------------------------
+ !
+ ! local variables
+ !
+ !-----------------------------------------------------------------
+
+ integer :: iEdge, nEdgesSolve, cell1, cell2, vertex1, vertex2, k
+ integer, dimension(:), pointer :: maxLevelEdgeTop
+ integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask
+
+ real (kind=RKIND) :: u_diffusion, invLength1, invLength2, visc2
+ real (kind=RKIND), dimension(:), pointer :: meshScaling, &
+ dcEdge, dvEdge
+
+ !-----------------------------------------------------------------
+ !
+ ! exit if this mixing is not selected
+ !
+ !-----------------------------------------------------------------
+
+ err = 0
+
+ if(.not.hmixLeithOn) return
+
+ nEdgesSolve = grid % nEdgesSolve
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ meshScaling => grid % meshScaling % array
+ edgeMask => grid % edgeMask % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+
+ do iEdge=1,nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ invLength1 = 1.0 / dcEdge(iEdge)
+ invLength2 = 1.0 / dvEdge(iEdge)
+
+ do k=1,maxLevelEdgeTop(iEdge)
+
+ ! Here -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ ! is - </font>
<font color="blue">abla vorticity pointing from vertex 2 to vertex 1, or equivalently
+ ! + k \times </font>
<font color="blue">abla vorticity pointing from cell1 to cell2.
+
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * invLength1 &
+ -viscVortCoef &
+ *( vorticity(k,vertex2) - vorticity(k,vertex1) ) * invLength2
+
+ ! Here the first line is (\delta x)^3
+ ! the second line is |</font>
<font color="blue">abla \omega|
+ ! and u_diffusion is </font>
<font color="gray">abla^2 u (see formula for $\bf{D}$ above).
+ visc2 = ( config_leith_parameter * config_leith_dx * meshScaling(iEdge) / 3.14)**3 &
+ * abs( vorticity(k,vertex2) - vorticity(k,vertex1) ) * invLength1 * sqrt(3.0)
+ visc2 = min(visc2, config_leith_visc2_max)
+
+ tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * visc2 * u_diffusion
+
+ viscosity(k,iEdge) = viscosity(k,iEdge) + visc2
+
+ end do
+ end do
+
+ !--------------------------------------------------------------------
+
+ end subroutine ocn_vel_hmix_leith_tend!}}}
+
+!***********************************************************************
+!
+! routine ocn_vel_hmix_leith_init
+!
+!> \brief Initializes ocean momentum horizontal mixing with Leith parameterization
+!> \author Mark Petersen
+!> \date 22 October 2012
+!> \version SVN:$Id$
+!> \details
+!> This routine initializes a variety of quantities related to
+!> Leith parameterization for horizontal momentum mixing in the ocean.
+!
+!-----------------------------------------------------------------------
+
+ subroutine ocn_vel_hmix_leith_init(err)!{{{
+
+
+ integer, intent(out) :: err !< Output: error flag
+
+ !--------------------------------------------------------------------
+ !
+ ! set some local module variables based on input config choices
+ !
+ !--------------------------------------------------------------------
+
+ err = 0
+
+ hmixLeithOn = .false.
+
+ if (config_use_leith_del2) then
+ hmixLeithOn = .true.
+
+ if (config_visc_vorticity_term) then
+ viscVortCoef = config_vorticity_del2_scale
+ else
+ viscVortCoef = 0.0
+ endif
+
+ endif
+
+ !--------------------------------------------------------------------
+
+ end subroutine ocn_vel_hmix_leith_init!}}}
+
+!***********************************************************************
+
+end module ocn_vel_hmix_leith
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+! vim: foldmethod=marker
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_pressure_grad.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_pressure_grad.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_pressure_grad.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -44,6 +44,7 @@
!
!--------------------------------------------------------------------
+ logical :: pgradOn
real (kind=RKIND) :: rho0Inv, grho0Inv
@@ -113,6 +114,8 @@
err = 0
+ if(.not.pgradOn) return
+
nEdgesSolve = grid % nEdgesSolve
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
cellsOnEdge => grid % cellsOnEdge % array
@@ -186,7 +189,9 @@
err = 0
- if (config_pressure_type.eq.'MontgomeryPotential') then
+ pgradOn = .true.
+
+ if (config_pressure_gradient_type.eq.'MontgomeryPotential') then
rho0Inv = 1.0
grho0Inv = 0.0
else
@@ -194,8 +199,10 @@
grho0Inv = gravity/config_rho0
end if
+ if(config_disable_u_pgrad) pgradOn = .false.
+
!--------------------------------------------------------------------
end subroutine ocn_vel_pressure_grad_init!}}}
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_vadv.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_vadv.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vel_vadv.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -183,10 +183,12 @@
err = 0
velVadvOn = .false.
- if (config_vert_grid_type.ne.'isopycnal') then
+ if (config_vert_coord_movement.ne.'isopycnal') then
velVadvOn = .true.
end if
+ if(config_disable_u_vadv) velVadvOn = .false.
+
!--------------------------------------------------------------------
end subroutine ocn_vel_vadv_init!}}}
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -15,6 +15,7 @@
module ocn_vmix
+ use mpas_kind_types
use mpas_grid_types
use mpas_configure
use mpas_timer
@@ -43,8 +44,6 @@
tridiagonal_solve_mult
public :: ocn_vmix_coefs, &
- ocn_vel_vmix_tend_explicit, &
- ocn_tracer_vmix_tend_explicit, &
ocn_vel_vmix_tend_implicit, &
ocn_tracer_vmix_tend_implicit, &
ocn_vmix_init, &
@@ -56,7 +55,7 @@
!
!--------------------------------------------------------------------
- logical :: explicitOn, implicitOn
+ logical :: velVmixOn, tracerVmixOn
!***********************************************************************
@@ -123,6 +122,9 @@
err = 0
+ d % vertViscTopOfEdge % array = 0.0_RKIND
+ d % vertDiffTopOfCell % array = 0.0_RKIND
+
call ocn_vmix_coefs_const_build(grid, s, d, err1)
call ocn_vmix_coefs_tanh_build(grid, s, d, err2)
call ocn_vmix_coefs_rich_build(grid, s, d, err3)
@@ -135,99 +137,6 @@
!***********************************************************************
!
-! routine ocn_vel_vmix_tendExplict
-!
-!> \brief Computes tendencies for explict momentum vertical mixing
-!> \author Doug Jacobsen
-!> \date 19 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the tendencies for explicit vertical mixing for momentum
-!> using computed coefficients.
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_vel_vmix_tend_explicit(grid, u, h_edge, vertViscTopOfEdge, tend, err)!{{{
-
- !-----------------------------------------------------------------
- !
- ! input variables
- !
- !-----------------------------------------------------------------
-
- type (mesh_type), intent(in) :: &
- grid !< Input: grid information
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- u !< Input: velocity
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- h_edge !< Input: thickness at edge
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- vertViscTopOfEdge !< Input: vertical mixing coefficients
-
- !-----------------------------------------------------------------
- !
- ! input/output variables
- !
- !-----------------------------------------------------------------
-
- real (kind=RKIND), dimension(:,:), intent(inout) :: &
- tend !< Input/Output: tendency information
-
- !-----------------------------------------------------------------
- !
- ! output variables
- !
- !-----------------------------------------------------------------
-
- integer, intent(out) :: err !< Output: error flag
-
- !-----------------------------------------------------------------
- !
- ! local variables
- !
- !-----------------------------------------------------------------
-
- integer :: iEdge, nEdgesSolve, k, nVertLevels
-
- integer, dimension(:), pointer :: maxLevelEdgeTop
-
- real (kind=RKIND), dimension(:), allocatable :: fluxVertTop
-
- err = 0
-
- if(implicitOn) return
-
- nEdgessolve = grid % nEdgesSolve
- nVertLevels = grid % nVertLevels
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
-
- allocate(fluxVertTop(nVertLevels+1))
- fluxVertTop(1) = 0.0
- do iEdge=1,nEdgesSolve
- do k=2,maxLevelEdgeTop(iEdge)
- fluxVertTop(k) = vertViscTopOfEdge(k,iEdge) &
- * ( u(k-1,iEdge) - u(k,iEdge) ) &
- * 2 / (h_edge(k-1,iEdge) + h_edge(k,iEdge))
- enddo
- fluxVertTop(maxLevelEdgeTop(iEdge)+1) = 0.0
-
- do k=1,maxLevelEdgeTop(iEdge)
- tend(k,iEdge) = tend(k,iEdge) &
- + (fluxVertTop(k) - fluxVertTop(k+1)) &
- / h_edge(k,iEdge)
- enddo
-
- end do
- deallocate(fluxVertTop)
- !--------------------------------------------------------------------
-
- end subroutine ocn_vel_vmix_tend_explicit!}}}
-
-!***********************************************************************
-!
! routine ocn_vel_vmix_tend_implicit
!
!> \brief Computes tendencies for implicit momentum vertical mixing
@@ -299,7 +208,7 @@
err = 0
- if(explicitOn) return
+ if(.not.velVmixOn) return
nEdges = grid % nEdges
nVertLevels = grid % nVertLevels
@@ -362,110 +271,6 @@
!***********************************************************************
!
-! routine ocn_tracer_vmix_tendExplict
-!
-!> \brief Computes tendencies for explict tracer vertical mixing
-!> \author Doug Jacobsen
-!> \date 19 September 2011
-!> \version SVN:$Id$
-!> \details
-!> This routine computes the tendencies for explicit vertical mixing for
-!> tracers using computed coefficients.
-!
-!-----------------------------------------------------------------------
-
- subroutine ocn_tracer_vmix_tend_explicit(grid, h, vertDiffTopOfCell, tracers, tend, err)!{{{
-
- !-----------------------------------------------------------------
- !
- ! input variables
- !
- !-----------------------------------------------------------------
-
- type (mesh_type), intent(in) :: &
- grid !< Input: grid information
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- h !< Input: thickness at cell center
-
- real (kind=RKIND), dimension(:,:), intent(in) :: &
- vertDiffTopOfCell !< Input: vertical mixing coefficients
-
- real (kind=RKIND), dimension(:,:,:), intent(in) :: &
- tracers !< Input: tracers
-
- !-----------------------------------------------------------------
- !
- ! input/output variables
- !
- !-----------------------------------------------------------------
-
- real (kind=RKIND), dimension(:,:,:), intent(inout) :: &
- tend !< Input/Output: tendency information
-
- !-----------------------------------------------------------------
- !
- ! output variables
- !
- !-----------------------------------------------------------------
-
- integer, intent(out) :: err !< Output: error flag
-
- !-----------------------------------------------------------------
- !
- ! local variables
- !
- !-----------------------------------------------------------------
-
- integer :: iCell, nCellsSolve, k, iTracer, num_tracers, nVertLevels
-
- integer, dimension(:), pointer :: maxLevelCell
-
- real (kind=RKIND), dimension(:,:), allocatable :: fluxVertTop
-
- err = 0
-
- if(implicitOn) return
-
- nCellsSolve = grid % nCellsSolve
- nVertLevels = grid % nVertLevels
- num_tracers = size(tracers, dim=1)
-
- maxLevelCell => grid % maxLevelCell % array
-
- allocate(fluxVertTop(num_tracers,nVertLevels+1))
- fluxVertTop(:,1) = 0.0
- do iCell=1,nCellsSolve
-
- do k=2,maxLevelCell(iCell)
- do iTracer=1,num_tracers
- ! compute \kappa_v d\phi/dz
- fluxVertTop(iTracer,k) = vertDiffTopOfCell(k,iCell) &
- * ( tracers(iTracer,k-1,iCell) &
- - tracers(iTracer,k ,iCell) ) &
- * 2 / (h(k-1,iCell) + h(k,iCell))
-
- enddo
- enddo
- fluxVertTop(:,maxLevelCell(iCell)+1) = 0.0
-
- do k=1,maxLevelCell(iCell)
- do iTracer=1,num_tracers
- ! This is h d/dz( fluxVertTop) but h and dz cancel, so
- ! reduces to delta( fluxVertTop)
- tend(iTracer,k,iCell) = tend(iTracer,k,iCell) &
- + fluxVertTop(iTracer,k) - fluxVertTop(iTracer,k+1)
- enddo
- enddo
-
- enddo ! iCell loop
- deallocate(fluxVertTop)
- !--------------------------------------------------------------------
-
- end subroutine ocn_tracer_vmix_tend_explicit!}}}
-
-!***********************************************************************
-!
! routine ocn_tracer_vmix_tend_implicit
!
!> \brief Computes tendencies for implicit tracer vertical mixing
@@ -530,7 +335,7 @@
err = 0
- if(explicitOn) return
+ if(.not.tracerVmixOn) return
nCells = grid % nCells
nVertLevels = grid % nVertLevels
@@ -640,8 +445,7 @@
!> \version SVN:$Id$
!> \details
!> This routine initializes a variety of quantities related to
-!> vertical mixing in the ocean. This primarily determines if
-!> explicit or implicit vertical mixing is to be used.
+!> vertical mixing in the ocean.
!
!-----------------------------------------------------------------------
@@ -662,13 +466,11 @@
err = 0
- explicitOn = .true.
- implicitOn = .false.
+ velVmixOn = .true.
+ tracerVmixOn = .true.
- if(config_implicit_vertical_mix) then
- explicitOn = .false.
- implicitOn = .true.
- end if
+ if(config_disable_u_vmix) velVmixOn = .false.
+ if(config_disable_tr_vmix) tracerVmixOn = .false.
call ocn_vmix_coefs_const_init(err1)
call ocn_vmix_coefs_tanh_init(err2)
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_const.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_const.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_const.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -121,7 +121,6 @@
!-----------------------------------------------------------------
err = 0
- if((.not.constViscOn) .and. (.not.constDiffOn)) return
vertViscTopOfEdge => d % vertViscTopOfEdge % array
vertDiffTopOfCell => d % vertDiffTopOfCell % array
@@ -185,7 +184,7 @@
if(.not.constViscOn) return
- vertViscTopOfEdge = constVisc
+ vertViscTopOfEdge = vertViscTopOfEdge + constVisc
!--------------------------------------------------------------------
@@ -241,7 +240,7 @@
if(.not.constDiffOn) return
- vertDiffTopOfCell = constDiff
+ vertDiffTopOfCell = vertDiffTopOfCell + constDiff
!--------------------------------------------------------------------
@@ -279,18 +278,20 @@
err = 0
- constViscOn = .false.
- constDiffOn = .false.
+ constViscOn = config_use_const_visc
+ constDiffOn = config_use_const_diff
+ constVisc = config_vert_visc
+ constDiff = config_vert_diff
- if (config_vert_visc_type.eq.'const') then
- constViscOn = .true.
- constVisc = config_vert_visc
- endif
+! if (config_vert_visc_type.eq.'const') then
+! constViscOn = .true.
+! constVisc = config_vert_visc
+! endif
- if (config_vert_diff_type.eq.'const') then
- constDiffOn = .true.
- constDiff = config_vert_diff
- endif
+! if (config_vert_diff_type.eq.'const') then
+! constDiffOn = .true.
+! constDiff = config_vert_diff
+! endif
!--------------------------------------------------------------------
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_rich.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_rich.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_rich.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -124,7 +124,6 @@
!-----------------------------------------------------------------
err = 0
- if((.not.richViscOn) .and. (.not.richDiffOn)) return
indexT = s%index_temperature
indexS = s%index_salinity
@@ -222,35 +221,21 @@
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- vertViscTopOfEdge = 0.0
do iEdge = 1,nEdges
do k = 2,maxLevelEdgeTop(iEdge)
! mrp 110324 efficiency note: this if is inside iEdge and k loops.
! Perhaps there is a more efficient way to do this.
if (RiTopOfEdge(k,iEdge)>0.0) then
- vertViscTopOfEdge(k,iEdge) = config_bkrd_vert_visc &
+ vertViscTopOfEdge(k,iEdge) = vertViscTopOfEdge(k, iEdge) + config_bkrd_vert_visc &
+ config_rich_mix / (1.0 + 5.0*RiTopOfEdge(k,iEdge))**2
- ! maltrud do limiting of coefficient--should not be necessary
- ! also probably better logic could be found
+ ! maltrud do limiting of coefficient--should not be necessary
+ ! also probably better logic could be found
if (vertViscTopOfEdge(k,iEdge) > config_convective_visc) then
- if( config_implicit_vertical_mix) then
- vertViscTopOfEdge(k,iEdge) = config_convective_visc
- else
- vertViscTopOfEdge(k,iEdge) = &
- ((h_edge(k-1,iEdge)+h_edge(k,iEdge))/2.0)**2/config_dt/4.0
- end if
+ vertViscTopOfEdge(k,iEdge) = config_convective_visc
end if
else
- ! mrp 110324 efficiency note: this if is inside iCell and k loops.
- if (config_implicit_vertical_mix) then
- ! for Ri<0 and implicit mix, use convective diffusion
- vertViscTopOfEdge(k,iEdge) = config_convective_visc
- else
- ! for Ri<0 and explicit vertical mix,
- ! use maximum diffusion allowed by CFL criterion
- vertViscTopOfEdge(k,iEdge) = &
- ((h_edge(k-1,iEdge)+h_edge(k,iEdge))/2.0)**2/config_dt/4.0
- end if
+ ! for Ri<0 use the convective value for the viscosity
+ vertViscTopOfEdge(k,iEdge) = config_convective_visc
end if
end do
end do
@@ -326,38 +311,24 @@
maxLevelCell => grid % maxLevelCell % array
- vertDiffTopOfCell = 0.0
coef = -gravity/config_rho0/2.0
do iCell = 1,nCells
do k = 2,maxLevelCell(iCell)
! mrp 110324 efficiency note: this if is inside iCell and k loops.
! Perhaps there is a more efficient way to do this.
if (RiTopOfCell(k,iCell)>0.0) then
- vertDiffTopOfCell(k,iCell) = config_bkrd_vert_diff &
+ vertDiffTopOfCell(k,iCell) = vertDiffTopOfCell(k, iCell) + config_bkrd_vert_diff &
+ (config_bkrd_vert_visc &
+ config_rich_mix / (1.0 + 5.0*RiTopOfCell(k,iCell))**2) &
/ (1.0 + 5.0*RiTopOfCell(k,iCell))
! maltrud do limiting of coefficient--should not be necessary
! also probably better logic could be found
if (vertDiffTopOfCell(k,iCell) > config_convective_diff) then
- if (config_implicit_vertical_mix) then
- vertDiffTopOfCell(k,iCell) = config_convective_diff
- else
- vertDiffTopOfCell(k,iCell) = &
- ((h(k-1,iCell)+h(k,iCell))/2.0)**2/config_dt/4.0
- end if
+ vertDiffTopOfCell(k,iCell) = config_convective_diff
end if
else
- ! mrp 110324 efficiency note: this if is inside iCell and k loops.
- if (config_implicit_vertical_mix) then
- ! for Ri<0 and implicit mix, use convective diffusion
- vertDiffTopOfCell(k,iCell) = config_convective_diff
- else
- ! for Ri<0 and explicit vertical mix,
- ! use maximum diffusion allowed by CFL criterion
- vertDiffTopOfCell(k,iCell) = &
- ((h(k-1,iCell)+h(k,iCell))/2.0)**2/config_dt/4.0
- end if
+ ! for Ri<0 use the convective value for the diffusion
+ vertDiffTopOfCell(k,iCell) = config_convective_diff
end if
end do
end do
@@ -427,13 +398,13 @@
!
!-----------------------------------------------------------------
- integer :: nVertLevels, nCells, nEdges, iCell, iEdge, k
+ integer :: nVertLevels, nCells, nEdges, iCell, iEdge, k, i
integer :: cell1, cell2
- integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot
- integer, dimension(:,:), pointer :: cellsOnEdge
+ integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, nEdgesOnCell
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOncell, edgeSignOnCell
- real (kind=RKIND) :: coef
+ real (kind=RKIND) :: coef, invAreaCell
real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell
real (kind=RKIND), dimension(:,:), allocatable :: drhoTopOfCell, du2TopOfCell, &
drhoTopOfEdge, du2TopOfEdge
@@ -453,6 +424,9 @@
dvEdge => grid % dvEdge % array
dcEdge => grid % dcEdge % array
areaCell => grid % areaCell % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ edgeSignOnCell => grid % edgeSignOnCell % array
allocate( &
drhoTopOfCell(nVertLevels+1,nCells+1), drhoTopOfEdge(nVertLevels+1,nEdges), &
@@ -498,21 +472,16 @@
! interpolate du2TopOfEdge to du2TopOfCell
du2TopOfCell = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=2,maxLevelEdgeBot(iEdge)
- du2TopOfCell(k,cell1) = du2TopOfCell(k,cell1) &
- + 0.5 * dcEdge(iEdge) * dvEdge(iEdge) * du2TopOfEdge(k,iEdge)
- du2TopOfCell(k,cell2) = du2TopOfCell(k,cell2) &
- + 0.5 * dcEdge(iEdge) * dvEdge(iEdge) * du2TopOfEdge(k,iEdge)
- end do
+ do iCell = 1, nCells
+ invAreaCell = 1.0 / areaCell(iCell)
+ do i = 1, nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i, iCell)
+
+ do k = 2, maxLevelEdgeBot(iEdge)
+ du2TopOfCell(k, iCell) = du2TopOfCell(k, iCell) + 0.5 * dcEdge(iEdge) * dvEdge(iEdge) * du2TopOfEdge(k, iEdge) * invAreaCell
+ end do
+ end do
end do
- do iCell = 1,nCells
- do k = 2,maxLevelCell(iCell)
- du2TopOfCell(k,iCell) = du2TopOfCell(k,iCell) / areaCell(iCell)
- end do
- end do
! compute RiTopOfEdge using drhoTopOfEdge and du2TopOfEdge
! coef = -g/rho_0/2
@@ -575,16 +544,16 @@
err = 0
- richViscOn = .false.
- richDiffOn = .false.
+ richViscOn = config_use_rich_visc
+ richDiffOn = config_use_rich_diff
- if (config_vert_visc_type.eq.'rich') then
- richViscOn = .true.
- endif
+! if (config_vert_visc_type.eq.'rich') then
+! richViscOn = .true.
+! endif
- if (config_vert_diff_type.eq.'rich') then
- richDiffOn = .true.
- endif
+! if (config_vert_diff_type.eq.'rich') then
+! richDiffOn = .true.
+! endif
!--------------------------------------------------------------------
Modified: branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F
===================================================================
--- branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -115,7 +115,6 @@
!-----------------------------------------------------------------
err = 0
- if((.not.tanhViscOn) .and. (.not.tanhDiffOn)) return
vertViscTopOfEdge => d % vertViscTopOfEdge % array
vertDiffTopOfCell => d % vertDiffTopOfCell % array
@@ -177,22 +176,21 @@
integer :: k, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: referenceBottomDepth
+ real (kind=RKIND), dimension(:), pointer :: refBottomDepth
err = 0
if(.not.tanhViscOn) return
nVertLevels = grid % nVertLevels
- referenceBottomDepth => grid % referenceBottomDepth % array
+ refBottomDepth => grid % refBottomDepth % array
- ! referenceBottomDepth is used here for simplicity. Using zMid and h, which
+ ! refBottomDepth is used here for simplicity. Using zMid and h, which
! vary in time, would give the exact location of the top, but it
! would only change the diffusion value very slightly.
- vertViscTopOfEdge = 0.0
do k=2,nVertLevels
- vertViscTopOfEdge(k,:) = -(config_max_visc_tanh-config_min_visc_tanh)/2.0 &
- *tanh((referenceBottomDepth(k-1)+config_ZMid_tanh) &
+ vertViscTopOfEdge(k,:) = vertViscTopOfEdge(k,:)-(config_max_visc_tanh-config_min_visc_tanh)/2.0 &
+ *tanh((refBottomDepth(k-1)+config_ZMid_tanh) &
/config_zWidth_tanh) &
+ (config_max_visc_tanh+config_min_visc_tanh)/2
end do
@@ -250,22 +248,21 @@
integer :: k, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: referenceBottomDepth
+ real (kind=RKIND), dimension(:), pointer :: refBottomDepth
err = 0
if(.not.tanhDiffOn) return
nVertLevels = grid % nVertLevels
- referenceBottomDepth => grid % referenceBottomDepth % array
+ refBottomDepth => grid % refBottomDepth % array
- ! referenceBottomDepth is used here for simplicity. Using zMid and h, which
+ ! refBottomDepth is used here for simplicity. Using zMid and h, which
! vary in time, would give the exact location of the top, but it
! would only change the diffusion value very slightly.
- vertDiffTopOfCell = 0.0
do k=2,nVertLevels
- vertDiffTopOfCell(k,:) = -(config_max_diff_tanh-config_min_diff_tanh)/2.0 &
- *tanh((referenceBottomDepth(k-1)+config_ZMid_tanh) &
+ vertDiffTopOfCell(k,:) = vertDiffTopOfCell(k,:)-(config_max_diff_tanh-config_min_diff_tanh)/2.0 &
+ *tanh((refBottomDepth(k-1)+config_ZMid_tanh) &
/config_zWidth_tanh) &
+ (config_max_diff_tanh+config_min_diff_tanh)/2
end do
@@ -305,16 +302,16 @@
err = 0
- tanhViscOn = .false.
- tanhDiffOn = .false.
+ tanhViscOn = config_use_tanh_visc
+ tanhDiffOn = config_use_tanh_diff
- if (config_vert_visc_type.eq.'tanh') then
- tanhViscOn = .true.
- endif
+! if (config_vert_visc_type.eq.'tanh') then
+! tanhViscOn = .true.
+! endif
- if (config_vert_diff_type.eq.'tanh') then
- tanhDiffOn = .true.
- endif
+! if (config_vert_diff_type.eq.'tanh') then
+! tanhDiffOn = .true.
+! endif
!--------------------------------------------------------------------
Modified: branches/ocean_projects/shared_advection/src/core_sw/Registry
===================================================================
--- branches/ocean_projects/shared_advection/src/core_sw/Registry 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/core_sw/Registry 2013-03-08 17:10:33 UTC (rev 2572)
@@ -97,7 +97,7 @@
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 persistent real cellTangentPlane ( R3 TWO nCells ) 0 o cellTangentPlane mesh - -
var persistent integer cellsOnCell ( maxEdges nCells ) 0 iro cellsOnCell mesh - -
var persistent integer verticesOnCell ( maxEdges nCells ) 0 iro verticesOnCell mesh - -
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_block_creator.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_block_creator.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_block_creator.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1041,7 +1041,6 @@
block_ptr % mesh % nCellsArray(:) = nCellsCursor % array(:)
block_ptr % mesh % nEdgesArray(:) = nEdgesCursor % array(:)
block_ptr % mesh % nVerticesArray(:) = nVerticesCursor % array(:)
- block_ptr % mesh % nVertLevelsSolve = nVertLevels ! No vertical Decomposition yet...
! Set block's local id
block_ptr % localBlockID = localBlockID
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_block_decomp.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_block_decomp.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_block_decomp.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -165,7 +165,7 @@
allocate(block_id(blocks_per_proc))
allocate(block_start(blocks_per_proc))
allocate(block_count(blocks_per_proc))
-
+
do i = 1, blocks_per_proc
block_start = 0
block_count = 0
@@ -436,11 +436,11 @@
end if
else
blocks_per_proc = 0
- do i = 1, total_blocks
+ do i = 0, total_blocks-1
call mpas_get_owning_proc(dminfo, i, owning_proc)
if(owning_proc == proc_number) then
call mpas_get_local_block_id(dminfo, i, local_block_id)
- blocks_per_proc = max(blocks_per_proc, local_block_id)
+ blocks_per_proc = max(blocks_per_proc, local_block_id+1)
end if
end do
end if
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_configure.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_configure.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_configure.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -7,11 +7,12 @@
contains
- subroutine mpas_read_namelist(dminfo)
+ subroutine mpas_read_namelist(dminfo, nml_filename)
implicit none
type (dm_info), intent(in) :: dminfo
+ character (len=*), optional :: nml_filename
integer :: funit, ierr
@@ -23,8 +24,13 @@
#include "config_set_defaults.inc"
if (dminfo % my_proc_id == IO_NODE) then
- write(0,*) 'Reading namelist.input'
- open(funit,file='namelist.input',status='old',form='formatted')
+ if (present(nml_filename)) then
+ write(0,*) 'Reading ', trim(nml_filename)
+ open(funit,file=trim(nml_filename),status='old',form='formatted')
+ else
+ write(0,*) 'Reading namelist.input'
+ open(funit,file='namelist.input',status='old',form='formatted')
+ end if
#include "config_namelist_reads.inc"
close(funit)
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_dmpar.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_dmpar.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_dmpar.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -25,6 +25,8 @@
module procedure mpas_dmpar_alltoall_field1d_real
module procedure mpas_dmpar_alltoall_field2d_real
module procedure mpas_dmpar_alltoall_field3d_real
+ module procedure mpas_dmpar_alltoall_field4d_real
+ module procedure mpas_dmpar_alltoall_field5d_real
end interface
private :: mpas_dmpar_alltoall_field1d_integer
@@ -32,6 +34,8 @@
private :: mpas_dmpar_alltoall_field1d_real
private :: mpas_dmpar_alltoall_field2d_real
private :: mpas_dmpar_alltoall_field3d_real
+ private :: mpas_dmpar_alltoall_field4d_real
+ private :: mpas_dmpar_alltoall_field5d_real
interface mpas_dmpar_exch_halo_field
@@ -41,6 +45,8 @@
module procedure mpas_dmpar_exch_halo_field1d_real
module procedure mpas_dmpar_exch_halo_field2d_real
module procedure mpas_dmpar_exch_halo_field3d_real
+ module procedure mpas_dmpar_exch_halo_field4d_real
+ module procedure mpas_dmpar_exch_halo_field5d_real
end interface
private :: mpas_dmpar_exch_halo_field1d_integer
@@ -49,6 +55,8 @@
private :: mpas_dmpar_exch_halo_field1d_real
private :: mpas_dmpar_exch_halo_field2d_real
private :: mpas_dmpar_exch_halo_field3d_real
+ private :: mpas_dmpar_exch_halo_field4d_real
+ private :: mpas_dmpar_exch_halo_field5d_real
interface mpas_dmpar_copy_field
module procedure mpas_dmpar_copy_field1d_integer
@@ -57,6 +65,8 @@
module procedure mpas_dmpar_copy_field1d_real
module procedure mpas_dmpar_copy_field2d_real
module procedure mpas_dmpar_copy_field3d_real
+ module procedure mpas_dmpar_copy_field4d_real
+ module procedure mpas_dmpar_copy_field5d_real
end interface
private :: mpas_dmpar_copy_field1d_integer
@@ -65,6 +75,8 @@
private :: mpas_dmpar_copy_field1d_real
private :: mpas_dmpar_copy_field2d_real
private :: mpas_dmpar_copy_field3d_real
+ private :: mpas_dmpar_copy_field4d_real
+ private :: mpas_dmpar_copy_field5d_real
contains
@@ -98,7 +110,9 @@
write(0,'(a,i5,a,i5,a)') 'task ', mpi_rank, ' of ', mpi_size, &
' is running'
+#ifndef MPAS_CESM
call open_streams(dminfo % my_proc_id)
+#endif
dminfo % info = MPI_INFO_NULL
#else
@@ -2808,7 +2822,610 @@
end subroutine mpas_dmpar_alltoall_field3d_real!}}}
+ subroutine mpas_dmpar_alltoall_field4d_real(fieldIn, fieldout, haloLayersIn)!{{{
+ implicit none
+
+ type (field4dReal), pointer :: fieldIn
+ type (field4dReal), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
+
+ type (field4dReal), pointer :: fieldInPtr, fieldOutPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
+
+ logical :: comm_list_found
+
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
+ integer :: mpi_ierr
+ integer :: iHalo, iBuffer, i, j, k, l
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ nullify(sendList)
+ nullify(recvList)
+
+ ! Setup recieve lists.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ if(.not.associated(recvList)) then
+ allocate(recvList)
+ nullify(recvList % next)
+ commListPtr => recvList
+ else
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
+
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
+
+ ! Determine size of receive list buffers.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = nAdded
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_realKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ if(.not.associated(sendList)) then
+ allocate(sendList)
+ nullify(sendList % next)
+ commListPtr => sendList
+ else
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(3)
+ do k = 1, fieldInPtr % dimSizes(2)
+ do l = 1, fieldInPtr % dimSizes(1)
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) &
+ + (j-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) &
+ + (k-1) * fieldInPtr % dimSizes(1) + l + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_realKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+#endif
+
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(:, :, :, exchListPtr % destList(i)) = fieldInPtr % array(:, :, :, exchListPtr % srcList(i))
+ end do
+ end if
+ fieldOutPtr => fieldOutPtr % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(3)
+ do k = 1, fieldOutPtr % dimSizes(2)
+ do l = 1, fieldOutPtr % dimSizes(1)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(1) &
+ + (j-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) &
+ + (k-1) * fieldOutPtr % dimSizes(1) + l + bufferOffset
+ fieldOutPtr % array(l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_alltoall_field4d_real!}}}
+
+ subroutine mpas_dmpar_alltoall_field5d_real(fieldIn, fieldout, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field5dReal), pointer :: fieldIn
+ type (field5dReal), pointer :: fieldOut
+ integer, dimension(:), pointer, optional :: haloLayersIn
+
+ type (field5dReal), pointer :: fieldInPtr, fieldOutPtr
+ type (mpas_exchange_list), pointer :: exchListPtr, exchListPtr2
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ type (dm_info), pointer :: dminfo
+
+ logical :: comm_list_found
+
+ integer :: lastPackedIdx, lastUnpackedIdx, nPacked, nUnpacked
+ integer :: nAdded, bufferOffset
+ integer :: mpi_ierr
+ integer :: iHalo, iBuffer, i, j, k, l, m
+ integer :: nHaloLayers
+ integer, dimension(:), pointer :: haloLayers
+
+ dminfo => fieldIn % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(fieldIn % sendList % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ nullify(sendList)
+ nullify(recvList)
+
+ ! Setup recieve lists.
+ do iHalo = 1, nHaloLayers
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ if(.not.associated(recvList)) then
+ allocate(recvList)
+ nullify(recvList % next)
+ commListPtr => recvList
+ else
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
+
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ end do
+
+ ! Determine size of receive list buffers.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = nAdded
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate buffers for recieves, and initiate mpi_irecv calls.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_realKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Setup send lists, and determine the size of their buffers.
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ ! Search for an already created commList to this processor.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointID) then
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldInPtr % dimSizes(4)
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! If no comm list exists, create a new one.
+ if(.not. comm_list_found) then
+ if(.not.associated(sendList)) then
+ allocate(sendList)
+ nullify(sendList % next)
+ commListPtr => sendList
+ else
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ end if
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldInPtr % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+ ! Allocate sendLists, copy data into buffer, and initiate mpi_isends
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldInPtr % dimSizes(4)
+ do k = 1, fieldInPtr % dimSizes(3)
+ do l = 1, fieldInPtr % dimSizes(2)
+ do m = 1, fieldInPtr % dimSizes(1)
+ iBuffer = (exchListPtr % destList(i)-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) * fieldInPtr % dimSizes(4) &
+ + (j-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) * fieldInPtr % dimSizes(3) &
+ + (k-1) * fieldInPtr % dimSizes(1) * fieldInPtr % dimSizes(2) &
+ + (l-1) * fieldInPtr % dimSizes(1) + m + bufferOffset
+ commListPtr % rbuffer(iBuffer) = fieldInPtr % array(m, l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldInPtr => fieldInPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nlist, MPI_realKIND, &
+ commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+#endif
+
+ ! Handle Local Copies. Only local copies if no MPI
+ do iHalo = 1, nHaloLayers
+ fieldInPtr => fieldIn
+ do while(associated(fieldInPtr))
+ exchListPtr => fieldInPtr % copyList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ if(exchListPtr % endPointID == fieldOutPtr % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldOutPtr % array(:, :, :, :, exchListPtr % destList(i)) = fieldInPtr % array(:, :, :, :, exchListPtr % srcList(i))
+ end do
+ end if
+ fieldOutPtr => fieldOutPtr % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ fieldInPtr => fieldInPtr % next
+ end do
+ end do
+
+#ifdef _MPI
+ ! Wait for MPI_Irecv's to finish, and unpack data.
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldOutPtr => fieldOut
+ do while(associated(fieldOutPtr))
+ exchListPtr => fieldOutPtr % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldOutPtr % dimSizes(4)
+ do k = 1, fieldOutPtr % dimSizes(3)
+ do l = 1, fieldOutPtr % dimSizes(2)
+ do m = 1, fieldOutPtr % dimSizes(1)
+ iBuffer = (exchListPtr % srcList(i)-1) * fieldOutPtr % dimSizes(4) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(1) &
+ + (j-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) &
+ + (k-1) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) &
+ + (l-1) * fieldOutPtr % dimSizes(1) + m + bufferOffset
+ fieldOutPtr % array(m, l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer(iBuffer)
+ end do
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldOutPtr % dimSizes(1) * fieldOutPtr % dimSizes(2) * fieldOutPtr % dimSizes(3) * fieldOutPtr % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldOutPtr => fieldOutPtr % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Wait for MPI_Isend's to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_alltoall_field5d_real!}}}
+
+
+
subroutine mpas_dmpar_exch_halo_field1d_integer(field, haloLayersIn)!{{{
implicit none
@@ -2827,6 +3444,12 @@
logical :: comm_list_found
+ do i = 1, 1
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
dminfo => field % block % domain % dminfo
if(present(haloLayersIn)) then
@@ -3101,6 +3724,12 @@
logical :: comm_list_found
+ do i = 1, 2
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
dminfo => field % block % domain % dminfo
if(present(haloLayersIn)) then
@@ -3376,6 +4005,12 @@
logical :: comm_list_found
+ do i = 1, 3
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
dminfo => field % block % domain % dminfo
if(present(haloLayersIn)) then
@@ -3657,6 +4292,12 @@
logical :: comm_list_found
+ do i = 1, 1
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
dminfo => field % block % domain % dminfo
if(present(haloLayersIn)) then
@@ -3928,7 +4569,13 @@
integer, dimension(:), pointer :: haloLayers
logical :: comm_list_found
-
+
+ do i = 1, 2
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
dminfo => field % block % domain % dminfo
if(present(haloLayersIn)) then
@@ -4206,6 +4853,12 @@
logical :: comm_list_found
+ do i = 1, 3
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
dminfo => field % block % domain % dminfo
if(present(haloLayersIn)) then
@@ -4469,6 +5122,602 @@
end subroutine mpas_dmpar_exch_halo_field3d_real!}}}
+ subroutine mpas_dmpar_exch_halo_field4d_real(field, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field4dReal), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
+
+ type (dm_info), pointer :: dminfo
+ type (field4dReal), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ integer :: mpi_ierr
+ integer :: nHaloLayers, iHalo, i, j, k, l
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
+
+ logical :: comm_list_found
+
+ do i = 1, 4
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
+ dminfo => field % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ ! Allocate communication lists, and setup dead header nodes
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
+ sendList % nList = 0
+
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
+ recvList % nList = 0
+
+ dminfo = field % block % domain % dminfo
+
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
+
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3)
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ ! Setup recv lists
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
+
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
+
+ ! Determine size of recv lists
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = bufferOffset
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(3)
+ do k = 1, fieldCursor % dimSizes(2)
+ do l = 1, fieldCursor % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (j-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (k-1) * fieldCursor % dimSizes(1) + l + bufferOffset) &
+ = fieldCursor % array(l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+#endif
+
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
+
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(:, :, :, exchListPtr % destList(i)) = fieldCursor % array(:, :, :, exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+
+#ifdef _MPI
+
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(3)
+ do k = 1, fieldCursor % dimSizes(2)
+ do l = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1)&
+ *fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) *fieldCursor % dimSizes(3)&
+ + (j-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (k-1)*fieldCursor % dimSizes(1) + l + bufferOffset)
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
+ end do
+
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_exch_halo_field4d_real!}}}
+
+ subroutine mpas_dmpar_exch_halo_field5d_real(field, haloLayersIn)!{{{
+
+ implicit none
+
+ type (field5dReal), pointer :: field
+ integer, dimension(:), intent(in), optional :: haloLayersIn
+
+ type (dm_info), pointer :: dminfo
+ type (field5dReal), pointer :: fieldCursor, fieldCursor2
+ type (mpas_exchange_list), pointer :: exchListPtr
+ type (mpas_communication_list), pointer :: sendList, recvList, commListPtr, commListPtr2
+ integer :: mpi_ierr
+ integer :: nHaloLayers, iHalo, i, j, k, l, m
+ integer :: bufferOffset, nAdded
+ integer, dimension(:), pointer :: haloLayers
+
+ logical :: comm_list_found
+
+ do i = 1, 5
+ if(field % dimSizes(i) <= 0) then
+ return
+ end if
+ end do
+
+ dminfo => field % block % domain % dminfo
+
+ if(present(haloLayersIn)) then
+ nHaloLayers = size(haloLayersIn)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = haloLayersIn(iHalo)
+ end do
+ else
+ nHaloLayers = size(field % sendList % halos)
+ allocate(haloLayers(nHaloLayers))
+ do iHalo = 1, nHaloLayers
+ haloLayers(iHalo) = iHalo
+ end do
+ end if
+
+#ifdef _MPI
+ ! Allocate communication lists, and setup dead header nodes
+ allocate(sendList)
+ nullify(sendList % next)
+ sendList % procID = -1
+ sendList % nList = 0
+
+ allocate(recvList)
+ nullify(recvList % next)
+ recvList % procID = -1
+ recvList % nList = 0
+
+ dminfo = field % block % domain % dminfo
+
+ ! Determine size of buffers for communication lists
+ fieldCursor => field
+ do while(associated(fieldCursor))
+
+ ! Need to aggregate across halo layers
+ do iHalo = 1, nHaloLayers
+
+ ! Determine size from send lists
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ commListPtr % nList = commListPtr % nList + exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => sendList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ commListPtr % nList = exchListPtr % nList * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ ! Setup recv lists
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ comm_list_found = .false.
+
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ if(commListPtr % procID == exchListPtr % endPointId) then
+ comm_list_found = .true.
+ exit
+ end if
+
+ commListPtr => commListPtr % next
+ end do
+
+ if(.not. comm_list_found) then
+ commListPtr => recvList
+ commListPtr2 => commListPtr % next
+ do while(associated(commListPtr2))
+ commListPtr => commListPtr % next
+ commListPtr2 => commListPtr % next
+ end do
+
+ allocate(commListPtr % next)
+ commListPtr => commListPtr % next
+ nullify(commListPtr % next)
+ commListPtr % procID = exchListPtr % endPointID
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+
+ ! Remove the dead head pointer on send and recv list
+ commListPtr => sendList
+ sendList => sendList % next
+ deallocate(commListPtr)
+
+ commListPtr => recvList
+ recvList => recvList % next
+ deallocate(commListPtr)
+
+ ! Determine size of recv lists
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr % nList = bufferOffset
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in recv lists, and initiate mpi_irecv calls
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr)
+
+ commListPtr => commListPtr % next
+ end do
+
+ ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ allocate(commListPtr % rbuffer(commListPtr % nList))
+ nullify(commListPtr % ibuffer)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(4)
+ do k = 1, fieldCursor % dimSizes(3)
+ do l = 1, fieldCursor % dimSizes(2)
+ do m = 1, fieldCursor % dimSizes(1)
+ commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4) &
+ + (j-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (k-1) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (l-1) * fieldCursor % dimSizes(1) + m + bufferOffset) &
+ = fieldCursor % array(m, l, k, j, exchListPtr % srcList(i))
+ nAdded = nAdded + 1
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+
+ call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+#endif
+
+ ! Handle local copy. If MPI is off, then only local copies are performed.
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ do iHalo = 1, nHaloLayers
+ exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList
+
+ do while(associated(exchListPtr))
+ fieldCursor2 => field
+ do while(associated(fieldCursor2))
+ if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then
+ do i = 1, exchListPtr % nList
+ fieldCursor2 % array(:, :, :, :, exchListPtr % destList(i)) = fieldCursor % array(:, :, :, :, exchListPtr % srcList(i))
+ end do
+ end if
+
+ fieldCursor2 => fieldCursor2 % next
+ end do
+
+ exchListPtr => exchListPtr % next
+ end do
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+
+#ifdef _MPI
+
+ ! Wait for mpi_irecv to finish, and unpack data from buffer
+ commListPtr => recvList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ bufferOffset = 0
+ do iHalo = 1, nHaloLayers
+ nAdded = 0
+ fieldCursor => field
+ do while(associated(fieldCursor))
+ exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList
+ do while(associated(exchListPtr))
+ if(exchListPtr % endPointID == commListPtr % procID) then
+ do i = 1, exchListPtr % nList
+ do j = 1, fieldCursor % dimSizes(4)
+ do k = 1, fieldCursor % dimSizes(3)
+ do l = 1, fieldCursor % dimSizes(2)
+ do m = 1, fieldCursor % dimSizes(1)
+ fieldCursor % array(m, l, k, j, exchListPtr % destList(i)) = commListPtr % rbuffer((exchListPtr % srcList(i)-1)&
+ *fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) *fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4)&
+ + (j-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) &
+ + (k-1)*fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) &
+ + (l-1)*fieldCursor % dimSizes(1) + m + bufferOffset)
+ end do
+ end do
+ end do
+ end do
+ end do
+ nAdded = max(nAdded, maxval(exchListPtr % srcList) * fieldCursor % dimSizes(1) * fieldCursor % dimSizes(2) * fieldCursor % dimSizes(3) * fieldCursor % dimSizes(4))
+ end if
+ exchListPtr => exchListPtr % next
+ end do
+
+ fieldCursor => fieldCursor % next
+ end do
+ bufferOffset = bufferOffset + nAdded
+ end do
+ commListPtr => commListPtr % next
+ end do
+
+ ! wait for mpi_isend to finish.
+ commListPtr => sendList
+ do while(associated(commListPtr))
+ call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr)
+ commListPtr => commListPtr % next
+ end do
+
+ ! Destroy commLists.
+ call mpas_dmpar_destroy_communication_list(sendList)
+ call mpas_dmpar_destroy_communication_list(recvList)
+#endif
+
+ deallocate(haloLayers)
+
+ end subroutine mpas_dmpar_exch_halo_field5d_real!}}}
+
subroutine mpas_dmpar_init_mulithalo_exchange_list(exchList, nHalos)!{{{
type (mpas_multihalo_exchange_list), pointer :: exchList
integer, intent(in) :: nHalos
@@ -4630,4 +5879,30 @@
end if
end subroutine mpas_dmpar_copy_field3d_real!}}}
+ subroutine mpas_dmpar_copy_field4d_real(field)!{{{
+ type (field4dReal), pointer :: field
+ type (field4dReal), pointer :: fieldCursor
+
+ if(associated(field % next)) then
+ fieldCursor => field % next
+ do while(associated(fieldCursor))
+ fieldCursor % array = field % array
+ fieldCursor => fieldCursor % next
+ end do
+ end if
+ end subroutine mpas_dmpar_copy_field4d_real!}}}
+
+ subroutine mpas_dmpar_copy_field5d_real(field)!{{{
+ type (field5dReal), pointer :: field
+ type (field5dReal), pointer :: fieldCursor
+
+ if(associated(field % next)) then
+ fieldCursor => field % next
+ do while(associated(fieldCursor))
+ fieldCursor % array = field % array
+ fieldCursor => fieldCursor % next
+ end do
+ end if
+ end subroutine mpas_dmpar_copy_field5d_real!}}}
+
end module mpas_dmpar
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_framework.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_framework.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_framework.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -13,20 +13,24 @@
contains
- subroutine mpas_framework_init(dminfo, domain)
+ subroutine mpas_framework_init(dminfo, domain, mpi_comm, nml_filename, io_system)
implicit none
type (dm_info), pointer :: dminfo
type (domain_type), pointer :: domain
+ integer, intent(in), optional :: mpi_comm
+ character (len=*), optional :: nml_filename
+ type (iosystem_desc_t), optional, pointer :: io_system
+
integer :: pio_num_iotasks
integer :: pio_stride
allocate(dminfo)
- call mpas_dmpar_init(dminfo)
+ call mpas_dmpar_init(dminfo, mpi_comm)
- call mpas_read_namelist(dminfo)
+ call mpas_read_namelist(dminfo, nml_filename)
call mpas_allocate_domain(domain, dminfo)
@@ -37,19 +41,20 @@
if (pio_num_iotasks == 0) then
pio_num_iotasks = domain % dminfo % nprocs
end if
- call MPAS_io_init(dminfo, pio_num_iotasks, pio_stride)
+ call MPAS_io_init(dminfo, pio_num_iotasks, pio_stride, io_system)
end subroutine mpas_framework_init
- subroutine mpas_framework_finalize(dminfo, domain)
+ subroutine mpas_framework_finalize(dminfo, domain, io_system)
implicit none
type (dm_info), pointer :: dminfo
type (domain_type), pointer :: domain
+ type (iosystem_desc_t), optional, pointer :: io_system
- call MPAS_io_finalize()
+ call MPAS_io_finalize(io_system)
call mpas_deallocate_domain(domain)
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_grid_types.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_grid_types.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_grid_types.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -20,8 +20,66 @@
logical :: output
end type io_info
+ ! Derived type for storing fields
+ type field5DReal
+
+ ! Back-pointer to the containing block
+ type (block_type), pointer :: block
+ ! Raw array holding field data on this block
+ real (kind=RKIND), dimension(:,:,:,:,:), pointer :: array
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=StrKIND) :: fieldName
+ character (len=StrKIND), dimension(:), pointer :: constituentNames => null()
+ character (len=StrKIND), dimension(5) :: dimNames
+ integer, dimension(5) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (field5DReal), pointer :: prev, next
+
+ ! Halo communication lists
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
+ end type field5DReal
+
+
! Derived type for storing fields
+ type field4DReal
+
+ ! Back-pointer to the containing block
+ type (block_type), pointer :: block
+
+ ! Raw array holding field data on this block
+ real (kind=RKIND), dimension(:,:,:,:), pointer :: array
+
+ ! Information used by the I/O layer
+ type (io_info), pointer :: ioinfo ! to be removed later
+ character (len=StrKIND) :: fieldName
+ character (len=StrKIND), dimension(:), pointer :: constituentNames => null()
+ character (len=StrKIND), dimension(4) :: dimNames
+ integer, dimension(4) :: dimSizes
+ logical :: hasTimeDimension
+ logical :: isSuperArray
+ type (att_list_type), pointer :: attList => null()
+
+ ! Pointers to the prev and next blocks for this field on this task
+ type (field4DReal), pointer :: prev, next
+
+ ! Halo communication lists
+ type (mpas_multihalo_exchange_list), pointer :: sendList
+ type (mpas_multihalo_exchange_list), pointer :: recvList
+ type (mpas_multihalo_exchange_list), pointer :: copyList
+ end type field4DReal
+
+
+
+ ! Derived type for storing fields
type field3DReal
! Back-pointer to the containing block
@@ -363,6 +421,30 @@
type (dm_info), pointer :: dminfo
end type domain_type
+ interface mpas_allocate_scratch_field
+ module procedure mpas_allocate_scratch_field1d_integer
+ module procedure mpas_allocate_scratch_field2d_integer
+ module procedure mpas_allocate_scratch_field3d_integer
+ module procedure mpas_allocate_scratch_field1d_real
+ module procedure mpas_allocate_scratch_field2d_real
+ module procedure mpas_allocate_scratch_field3d_real
+ module procedure mpas_allocate_scratch_field4d_real
+ module procedure mpas_allocate_scratch_field5d_real
+ module procedure mpas_allocate_scratch_field1d_char
+ end interface
+
+ interface mpas_deallocate_scratch_field
+ module procedure mpas_deallocate_scratch_field1d_integer
+ module procedure mpas_deallocate_scratch_field2d_integer
+ module procedure mpas_deallocate_scratch_field3d_integer
+ module procedure mpas_deallocate_scratch_field1d_real
+ module procedure mpas_deallocate_scratch_field2d_real
+ module procedure mpas_deallocate_scratch_field3d_real
+ module procedure mpas_deallocate_scratch_field4d_real
+ module procedure mpas_deallocate_scratch_field5d_real
+ module procedure mpas_deallocate_scratch_field1d_char
+ end interface
+
interface mpas_deallocate_field
module procedure mpas_deallocate_field0d_integer
module procedure mpas_deallocate_field1d_integer
@@ -372,6 +454,8 @@
module procedure mpas_deallocate_field1d_real
module procedure mpas_deallocate_field2d_real
module procedure mpas_deallocate_field3d_real
+ module procedure mpas_deallocate_field4d_real
+ module procedure mpas_deallocate_field5d_real
module procedure mpas_deallocate_field0d_char
module procedure mpas_deallocate_field1d_char
end interface
@@ -444,6 +528,520 @@
end subroutine mpas_deallocate_domain!}}}
+ subroutine mpas_allocate_scratch_field1d_integer(f, single_block_in)!{{{
+ type (field1dInteger), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field1dInteger), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field1d_integer!}}}
+
+ subroutine mpas_allocate_scratch_field2d_integer(f, single_block_in)!{{{
+ type (field2dInteger), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field2dInteger), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field2d_integer!}}}
+
+ subroutine mpas_allocate_scratch_field3d_integer(f, single_block_in)!{{{
+ type (field3dInteger), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field3dInteger), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2), f_cursor % dimSizes(3)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2), f % dimSizes(3)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field3d_integer!}}}
+
+ subroutine mpas_allocate_scratch_field1d_real(f, single_block_in)!{{{
+ type (field1dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field1dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field1d_real!}}}
+
+ subroutine mpas_allocate_scratch_field2d_real(f, single_block_in)!{{{
+ type (field2dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field2dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field2d_real!}}}
+
+ subroutine mpas_allocate_scratch_field3d_real(f, single_block_in)!{{{
+ type (field3dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field3dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2), f_cursor % dimSizes(3)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2), f % dimSizes(3)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field3d_real!}}}
+
+ subroutine mpas_allocate_scratch_field4d_real(f, single_block_in)!{{{
+ type (field4dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field4dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2), f_cursor % dimSizes(3), f_cursor % dimSizes(4)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2), f % dimSizes(3), f % dimSizes(4)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field4d_real!}}}
+
+ subroutine mpas_allocate_scratch_field5d_real(f, single_block_in)!{{{
+ type (field5dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field5dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1), f_cursor % dimSizes(2), f_cursor % dimSizes(3), f_cursor % dimSizes(4), f_cursor % dimSizes(5)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1), f % dimSizes(2), f % dimSizes(3), f % dimSizes(4), f % dimSizes(5)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field5d_real!}}}
+
+ subroutine mpas_allocate_scratch_field1d_char(f, single_block_in)!{{{
+ type (field1dChar), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field1dChar), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not. single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(.not.associated(f_cursor % array)) then
+ allocate(f_cursor % array(f_cursor % dimSizes(1)))
+ end if
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(.not.associated(f % array)) then
+ allocate(f % array(f % dimSizes(1)))
+ end if
+ end if
+
+ end subroutine mpas_allocate_scratch_field1d_char!}}}
+
+ subroutine mpas_deallocate_scratch_field1d_integer(f, single_block_in)!{{{
+ type (field1dInteger), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field1dInteger), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field1d_integer!}}}
+
+ subroutine mpas_deallocate_scratch_field2d_integer(f, single_block_in)!{{{
+ type (field2dInteger), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field2dInteger), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field2d_integer!}}}
+
+ subroutine mpas_deallocate_scratch_field3d_integer(f, single_block_in)!{{{
+ type (field3dInteger), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field3dInteger), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field3d_integer!}}}
+
+ subroutine mpas_deallocate_scratch_field1d_real(f, single_block_in)!{{{
+ type (field1dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field1dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field1d_real!}}}
+
+ subroutine mpas_deallocate_scratch_field2d_real(f, single_block_in)!{{{
+ type (field2dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field2dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field2d_real!}}}
+
+ subroutine mpas_deallocate_scratch_field3d_real(f, single_block_in)!{{{
+ type (field3dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field3dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field3d_real!}}}
+
+ subroutine mpas_deallocate_scratch_field4d_real(f, single_block_in)!{{{
+ type (field4dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field4dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field4d_real!}}}
+
+ subroutine mpas_deallocate_scratch_field5d_real(f, single_block_in)!{{{
+ type (field5dReal), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field5dReal), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field5d_real!}}}
+
+ subroutine mpas_deallocate_scratch_field1d_char(f, single_block_in)!{{{
+ type (field1dChar), pointer :: f
+ logical, intent(in), optional :: single_block_in
+ logical :: single_block
+ type (field1dChar), pointer :: f_cursor
+
+ if(present(single_block_in)) then
+ single_block = single_block_in
+ else
+ single_block = .false.
+ end if
+
+ if(.not.single_block) then
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ f_cursor => f_cursor % next
+ end do
+ else
+ if(associated(f % array)) then
+ deallocate(f % array)
+ end if
+ end if
+
+ end subroutine mpas_deallocate_scratch_field1d_char!}}}
+
+
subroutine mpas_deallocate_field0d_integer(f)!{{{
type (field0dInteger), pointer :: f
type (field0dInteger), pointer :: f_cursor
@@ -653,6 +1251,60 @@
end subroutine mpas_deallocate_field3d_real!}}}
+ subroutine mpas_deallocate_field4d_real(f)!{{{
+ type (field4dReal), pointer :: f
+ type (field4dReal), pointer :: f_cursor
+
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f % next)) then
+ f => f % next
+ else
+ nullify(f)
+ end if
+
+ if(associated(f_cursor % ioinfo)) then
+ deallocate(f_cursor % ioinfo)
+ end if
+
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ deallocate(f_cursor)
+
+ f_cursor => f
+ end do
+
+ end subroutine mpas_deallocate_field4d_real!}}}
+
+ subroutine mpas_deallocate_field5d_real(f)!{{{
+ type (field5dReal), pointer :: f
+ type (field5dReal), pointer :: f_cursor
+
+ f_cursor => f
+ do while(associated(f_cursor))
+ if(associated(f % next)) then
+ f => f % next
+ else
+ nullify(f)
+ end if
+
+ if(associated(f_cursor % ioinfo)) then
+ deallocate(f_cursor % ioinfo)
+ end if
+
+ if(associated(f_cursor % array)) then
+ deallocate(f_cursor % array)
+ end if
+
+ deallocate(f_cursor)
+
+ f_cursor => f
+ end do
+
+ end subroutine mpas_deallocate_field5d_real!}}}
+
subroutine mpas_deallocate_field0d_char(f)!{{{
type (field0dChar), pointer :: f
type (field0dChar), pointer :: f_cursor
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_io.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_io.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_io.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -77,6 +77,7 @@
module procedure MPAS_io_get_var_real2d
module procedure MPAS_io_get_var_real3d
module procedure MPAS_io_get_var_real4d
+ module procedure MPAS_io_get_var_real5d
module procedure MPAS_io_get_var_char0d
end interface MPAS_io_get_var
@@ -91,6 +92,7 @@
module procedure MPAS_io_put_var_real2d
module procedure MPAS_io_put_var_real3d
module procedure MPAS_io_put_var_real4d
+ module procedure MPAS_io_put_var_real5d
module procedure MPAS_io_put_var_char0d
end interface MPAS_io_put_var
@@ -176,21 +178,21 @@
type (fieldlist_type), pointer :: next => null()
end type fieldlist_type
- type (iosystem_desc_t), private, save :: pio_iosystem
+ type (iosystem_desc_t), pointer, private, save :: pio_iosystem
type (decomplist_type), pointer, private :: decomp_list => null()
type (dm_info), private :: local_dminfo
contains
+ subroutine MPAS_io_init(dminfo, io_task_count, io_task_stride, io_system, ierr)
- subroutine MPAS_io_init(dminfo, io_task_count, io_task_stride, ierr)
-
implicit none
type (dm_info), intent(in) :: dminfo
integer, intent(in) :: io_task_count
integer, intent(in) :: io_task_stride
+ type (iosystem_desc_t), optional, pointer :: io_system
integer, intent(out), optional :: ierr
! write(0,*) 'Called MPAS_io_init()'
@@ -198,17 +200,22 @@
local_dminfo = dminfo
+ if(present(io_system)) then
+ pio_iosystem => io_system
+ else
!write(0,*) 'MGD PIO_init'
- call PIO_init(local_dminfo % my_proc_id, & ! comp_rank
- local_dminfo % comm, & ! comp_comm
- io_task_count, & ! num_iotasks
- 0, & ! num_aggregator
- io_task_stride, & ! stride
- PIO_rearr_box, & ! rearr
- pio_iosystem) ! iosystem
+ allocate(pio_iosystem)
+ call PIO_init(local_dminfo % my_proc_id, & ! comp_rank
+ local_dminfo % comm, & ! comp_comm
+ io_task_count, & ! num_iotasks
+ 0, & ! num_aggregator
+ io_task_stride, & ! stride
+ PIO_rearr_box, & ! rearr
+ pio_iosystem) ! iosystem
+
+ call pio_seterrorhandling(pio_iosystem, PIO_BCAST_ERROR)
+ end if
- call pio_seterrorhandling(pio_iosystem, PIO_BCAST_ERROR)
-
end subroutine MPAS_io_init
@@ -366,6 +373,7 @@
if (present(ierr)) ierr = MPAS_IO_ERR_PIO
deallocate(new_dimlist_node % dimhandle)
deallocate(new_dimlist_node)
+ write(0,*) 'WARNING: Dimension ', trim(dimname), ' not in input file.'
dimsize = -1
return
end if
@@ -551,6 +559,7 @@
if (present(ierr)) ierr = MPAS_IO_ERR_PIO
deallocate(new_fieldlist_node % fieldhandle)
deallocate(new_fieldlist_node)
+ write(0,*) 'WARNING: Variable ', trim(fieldname), ' not in input file.'
return
end if
!write(0,*) 'Inquired about variable ID', new_fieldlist_node % fieldhandle % fieldid
@@ -911,9 +920,12 @@
type (fieldlist_type), pointer :: field_cursor
integer :: pio_type
- integer :: ndims, pd
- integer :: i, i1, i2, i3, i4, i5, indx
- integer, dimension(:), pointer :: dimlist, compdof
+ integer :: ndims
+ integer (kind=PIO_OFFSET) :: pd, indx
+ integer :: i
+ integer (kind=PIO_OFFSET) :: i1, i2, i3, i4, i5
+ integer, dimension(:), pointer :: dimlist
+ integer (kind=PIO_OFFSET), dimension(:), pointer :: compdof
type (decomplist_type), pointer :: decomp_cursor, new_decomp
! write(0,*) 'Called MPAS_io_set_var_indices()'
@@ -926,8 +938,6 @@
end if
! write(0,*) 'Assigning ', size(indices), ' indices for ', trim(fieldname)
-
-
!
! Check whether the field has been defined
!
@@ -1042,7 +1052,7 @@
pio_type = PIO_int
else if (field_cursor % fieldhandle % field_type == MPAS_IO_CHAR) then
pio_type = PIO_char
-!!!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!!
+ !!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!!
end if
allocate(dimlist(ndims))
@@ -1051,11 +1061,11 @@
do i=1,ndims-1
dimlist(i) = field_cursor % fieldhandle % dims(i) % dimsize
new_decomp % decomphandle % dims(i) = dimlist(i)
- pd = pd * dimlist(i)
+ pd = pd * int(dimlist(i),PIO_OFFSET)
end do
new_decomp % decomphandle % dims(ndims) = field_cursor % fieldhandle % dims(ndims) % dimsize
dimlist(ndims) = size(indices)
- pd = pd * dimlist(ndims)
+ pd = pd * int(dimlist(ndims),PIO_OFFSET)
allocate(compdof(pd))
@@ -1067,10 +1077,10 @@
do i2=1,dimlist(2)
do i1=1,dimlist(1)
compdof(indx) = i1 &
- + (i2-1)*dimlist(1) &
- + (i3-1)*dimlist(2)*dimlist(1) &
- + (i4-1)*dimlist(3)*dimlist(2)*dimlist(1) &
- + (indices(i5)-1)*dimlist(4)*dimlist(3)*dimlist(2)*dimlist(1)
+ + (i2-1)*int(dimlist(1),PIO_OFFSET) &
+ + (i3-1)*int(dimlist(2),PIO_OFFSET)*int(dimlist(1),PIO_OFFSET) &
+ + (i4-1)*int(dimlist(3),PIO_OFFSET)*int(dimlist(2),PIO_OFFSET)*int(dimlist(1),PIO_OFFSET) &
+ + int(indices(i5)-1,PIO_OFFSET)*int(dimlist(4),PIO_OFFSET)*int(dimlist(3),PIO_OFFSET)*int(dimlist(2),PIO_OFFSET)*int(dimlist(1),PIO_OFFSET)
indx = indx + 1
end do
end do
@@ -1083,9 +1093,9 @@
do i2=1,dimlist(2)
do i1=1,dimlist(1)
compdof(indx) = i1 &
- + (i2-1)*dimlist(1) &
- + (i3-1)*dimlist(2)*dimlist(1) &
- + (indices(i4)-1)*dimlist(3)*dimlist(2)*dimlist(1)
+ + (i2-1)*int(dimlist(1),PIO_OFFSET) &
+ + (i3-1)*int(dimlist(2),PIO_OFFSET)*int(dimlist(1),PIO_OFFSET) &
+ + int(indices(i4)-1,PIO_OFFSET)*int(dimlist(3),PIO_OFFSET)*int(dimlist(2),PIO_OFFSET)*int(dimlist(1),PIO_OFFSET)
indx = indx + 1
end do
end do
@@ -1095,7 +1105,7 @@
do i3=1,dimlist(3)
do i2=1,dimlist(2)
do i1=1,dimlist(1)
- compdof(indx) = i1 + (i2-1)*dimlist(1) + (indices(i3)-1)*dimlist(2)*dimlist(1)
+ compdof(indx) = i1 + (i2-1)*int(dimlist(1),PIO_OFFSET) + int(indices(i3)-1,PIO_OFFSET)*int(dimlist(2),PIO_OFFSET)*int(dimlist(1),PIO_OFFSET)
indx = indx + 1
end do
end do
@@ -1103,13 +1113,13 @@
else if (ndims == 2) then
do i2=1,dimlist(2)
do i1=1,dimlist(1)
- compdof(indx) = i1 + (indices(i2)-1)*dimlist(1)
+ compdof(indx) = i1 + int(indices(i2)-1,PIO_OFFSET)*int(dimlist(1),PIO_OFFSET)
indx = indx + 1
end do
end do
else if (ndims == 1) then
do i1=1,dimlist(1)
- compdof(indx) = indices(i1)
+ compdof(indx) = int(indices(i1),PIO_OFFSET)
indx = indx + 1
end do
end if
@@ -1138,7 +1148,7 @@
subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, &
- realVal, realArray1d, realArray2d, realArray3d, realArray4d, &
+ realVal, realArray1d, realArray2d, realArray3d, realArray4d, realArray5d, &
charVal, ierr)
implicit none
@@ -1155,6 +1165,7 @@
real (kind=RKIND), dimension(:,:), intent(out), optional :: realArray2d
real (kind=RKIND), dimension(:,:,:), intent(out), optional :: realArray3d
real (kind=RKIND), dimension(:,:,:,:), intent(out), optional :: realArray4d
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(out), optional :: realArray5d
character (len=*), intent(out), optional :: charVal
integer, intent(out), optional :: ierr
@@ -1255,6 +1266,10 @@
! write (0,*) ' value is real4'
call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
realArray4d, pio_ierr)
+ else if (present(realArray5d)) then
+! write (0,*) ' value is real5'
+ call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray5d, pio_ierr)
else if (present(intArray1d)) then
! write (0,*) ' value is int1'
call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
@@ -1484,6 +1499,26 @@
end subroutine MPAS_io_get_var_real4d
+ subroutine MPAS_io_get_var_real5d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(out) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_get_var_real5d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_get_var_generic(handle, fieldname, realArray5d=array, ierr=ierr)
+
+ end subroutine MPAS_io_get_var_real5d
+
+
subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr)
implicit none
@@ -1505,7 +1540,7 @@
subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, &
- realVal, realArray1d, realArray2d, realArray3d, realArray4d, &
+ realVal, realArray1d, realArray2d, realArray3d, realArray4d, realArray5d, &
charVal, ierr)
implicit none
@@ -1522,6 +1557,7 @@
real (kind=RKIND), dimension(:,:), intent(in), optional :: realArray2d
real (kind=RKIND), dimension(:,:,:), intent(in), optional :: realArray3d
real (kind=RKIND), dimension(:,:,:,:), intent(in), optional :: realArray4d
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(in), optional :: realArray5d
character (len=*), intent(in), optional :: charVal
integer, intent(out), optional :: ierr
@@ -1621,6 +1657,9 @@
else if (present(realArray4d)) then
call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
realArray4d, pio_ierr)
+ else if (present(realArray5d)) then
+ call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
+ realArray5d, pio_ierr)
else if (present(intArray1d)) then
call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, &
intArray1d, pio_ierr)
@@ -1844,6 +1883,26 @@
end subroutine MPAS_io_put_var_real4d
+ subroutine MPAS_io_put_var_real5d(handle, fieldname, array, ierr)
+
+ implicit none
+
+ type (MPAS_IO_Handle_type), intent(inout) :: handle
+ character (len=*), intent(in) :: fieldname
+ real (kind=RKIND), dimension(:,:,:,:,:), intent(in) :: array
+ integer, intent(out), optional :: ierr
+
+ integer :: pio_ierr
+ type (fieldlist_type), pointer :: field_cursor
+
+! write(0,*) 'Called MPAS_io_put_var_real5d()'
+ if (present(ierr)) ierr = MPAS_IO_NOERR
+
+ call MPAS_io_put_var_generic(handle, fieldname, realArray5d=array, ierr=ierr)
+
+ end subroutine MPAS_io_put_var_real5d
+
+
subroutine MPAS_io_put_var_char0d(handle, fieldname, val, ierr)
implicit none
@@ -3383,10 +3442,11 @@
end subroutine MPAS_io_close
- subroutine MPAS_io_finalize(ierr)
+ subroutine MPAS_io_finalize(io_system, ierr)
implicit none
+ type (iosystem_desc_t), optional, pointer :: io_system
integer, intent(out), optional :: ierr
integer :: pio_ierr
@@ -3409,10 +3469,13 @@
end do
!write(0,*) 'MGD PIO_finalize'
- call PIO_finalize(pio_iosystem, pio_ierr)
- if (pio_ierr /= PIO_noerr) then
- if (present(ierr)) ierr = MPAS_IO_ERR_PIO
- return
+ if(.not.present(io_system)) then
+ call PIO_finalize(pio_iosystem, pio_ierr)
+ if (pio_ierr /= PIO_noerr) then
+ if (present(ierr)) ierr = MPAS_IO_ERR_PIO
+ return
+ end if
+ deallocate(pio_iosystem)
end if
end subroutine MPAS_io_finalize
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_io_input.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_io_input.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_io_input.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -30,7 +30,6 @@
integer :: readCellStart, readCellEnd, nReadCells
integer :: readEdgeStart, readEdgeEnd, nReadEdges
integer :: readVertexStart, readVertexEnd, nReadVertices
- integer :: readVertLevelStart, readVertLevelEnd, nReadVertLevels
contains
@@ -95,7 +94,7 @@
type (graph) :: partial_global_graph_info
type (MPAS_Time_type) :: startTime
- character(len=StrKIND) :: timeStamp
+ character(len=StrKIND) :: timeStamp, restartTimeStamp
character(len=StrKIND) :: filename
integer :: nHalos
@@ -104,9 +103,18 @@
if (config_do_restart) then
! this get followed by set is to ensure that the time is in standard format
- call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time)
+ if(trim(config_start_time) == 'file') then
+ open(22,file='restart_timestamp',form='formatted',status='old')
+ read(22,*) restartTimeStamp
+ close(22)
+
+ else
+ restartTimeStamp = config_start_time
+ end if
+
+ write(0,*) 'RestartTimeStamp ', trim(restartTimeStamp)
+ call mpas_set_time(curr_time=startTime, dateTimeString=restartTimeStamp)
call mpas_get_time(curr_time=startTime, dateTimeString=timeStamp)
-
call mpas_insert_string_suffix(trim(config_restart_name), timeStamp, filename)
input_obj % filename = trim(filename)
@@ -147,10 +155,6 @@
call mpas_dmpar_get_index_range(domain % dminfo, 1, nVertices, readVertexStart, readVertexEnd)
nReadVertices = readVertexEnd - readVertexStart + 1
- readVertLevelStart = 1
- readVertLevelEnd = nVertLevels
- nReadVertLevels = nVertLevels
-
allocate(readingBlock)
readingBlock % domain => domain
readingBlock % blockID = domain % dminfo % my_proc_id
@@ -245,7 +249,6 @@
do while (associated(block_ptr))
block_ptr % mesh % sphere_radius = domain % blocklist % mesh % sphere_radius
block_ptr % mesh % on_a_sphere = domain % blocklist % mesh % on_a_sphere
- block_ptr % mesh % nVertLevelsSolve = domain % blocklist % mesh % nVertLevelsSolve ! No vertical decomp yet...
! Link the sendList and recvList pointers in each field type to the appropriate lists
! in parinfo, e.g., cellsToSend and cellsToRecv; in future, it can also be extended to
@@ -262,13 +265,19 @@
! If doing a restart, we need to decide which time slice to read from the
! restart file
!
- input_obj % time = MPAS_seekStream(input_obj % io_stream, config_start_time, MPAS_STREAM_EXACT_TIME, timeStamp, ierr)
+ input_obj % time = MPAS_seekStream(input_obj % io_stream, restartTimeStamp, MPAS_STREAM_EXACT_TIME, timeStamp, ierr)
if (ierr == MPAS_IO_ERR) then
- write(0,*) 'Error: restart file '//trim(filename)//' did not contain time '//trim(config_start_time)
+ write(0,*) 'Error: restart file '//trim(filename)//' did not contain time '//trim(restartTimeStamp)
call mpas_dmpar_abort(domain % dminfo)
end if
+
+! input_obj % time = MPAS_seekStream(input_obj % io_stream, config_start_time, MPAS_STREAM_EXACT_TIME, timeStamp, ierr)
+! if (ierr == MPAS_IO_ERR) then
+! write(0,*) 'Error: restart file '//trim(filename)//' did not contain time '//trim(config_start_time)
+! call mpas_dmpar_abort(domain % dminfo)
+! end if
!write(0,*) 'MGD DEBUGGING time = ', input_obj % time
- write(0,*) 'Restarting model from time ', timeStamp
+ write(0,*) 'Restarting model from time ', trim(timeStamp)
end if
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -279,7 +288,7 @@
! process
! 2) All processes then send the global indices that were read to the
! processes that own those indices based on
- ! {send,recv}{Cell,Edge,Vertex,VertLevel}List
+ ! {send,recv}{Cell,Edge,Vertex}List
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
call mpas_read_and_distribute_fields(input_obj)
@@ -522,7 +531,7 @@
integer :: ierr
- call MPAS_readStream(input_obj % io_stream, 1, ierr)
+ call MPAS_readStream(input_obj % io_stream, input_obj % time, ierr)
end subroutine mpas_read_and_distribute_fields!}}}
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_io_output.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_io_output.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_io_output.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -48,6 +48,9 @@
else if (trim(stream) == 'RESTART') then
if(present(outputSuffix)) then
call mpas_insert_string_suffix(config_restart_name, outputSuffix, tempfilename)
+ open(22,file='restart_timestamp',form='formatted',status='replace')
+ write(22,*) outputSuffix
+ close(22)
else
tempfilename = config_restart_name
end if
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_io_streams.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_io_streams.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_io_streams.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -19,6 +19,8 @@
type (field1dReal), pointer :: real1dField => null()
type (field2dReal), pointer :: real2dField => null()
type (field3dReal), pointer :: real3dField => null()
+ type (field4dReal), pointer :: real4dField => null()
+ type (field5dReal), pointer :: real5dField => null()
type (field0dChar), pointer :: char0dField => null()
type (field1dChar), pointer :: char1dField => null()
type (field_list_type), pointer :: next => null()
@@ -44,6 +46,8 @@
module procedure MPAS_streamAddField_1dReal
module procedure MPAS_streamAddField_2dReal
module procedure MPAS_streamAddField_3dReal
+ module procedure MPAS_streamAddField_4dReal
+ module procedure MPAS_streamAddField_5dReal
module procedure MPAS_streamAddField_0dChar
end interface MPAS_streamAddField
@@ -82,8 +86,10 @@
FIELD_1D_REAL = 6, &
FIELD_2D_REAL = 7, &
FIELD_3D_REAL = 8, &
- FIELD_0D_CHAR = 9, &
- FIELD_1D_CHAR = 10
+ FIELD_4D_REAL = 9, &
+ FIELD_5D_REAL = 10, &
+ FIELD_0D_CHAR = 11, &
+ FIELD_1D_CHAR = 12
private mergeArrays
@@ -996,6 +1002,208 @@
end subroutine MPAS_streamAddField_3dReal
+ subroutine MPAS_streamAddField_4dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field4DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field4dReal), pointer :: field_ptr
+ character (len=StrKIND), dimension(5) :: dimNames
+ character (len=StrKIND), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+!write(0,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^ we are adding a super-array'
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_4D_REAL
+ new_field_list_node % real4dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+!write(0,*) 'DEBUGGING : Finished adding 4d real field '//trim(field % fieldName)
+
+ end subroutine MPAS_streamAddField_4dReal
+
+
+ subroutine MPAS_streamAddField_5dReal(stream, field, ierr)
+
+ implicit none
+
+ type (MPAS_Stream_type), intent(inout) :: stream
+ type (field5DReal), intent(in), target :: field
+ integer, intent(out), optional :: ierr
+
+ integer :: io_err
+ integer :: i
+ integer :: idim
+ integer :: totalDimSize, globalDimSize
+ logical :: isDecomposed
+ integer :: ndims
+ type (field5dReal), pointer :: field_ptr
+ character (len=StrKIND), dimension(5) :: dimNames
+ character (len=StrKIND), dimension(:), pointer :: dimNamesInq
+ integer, dimension(:), pointer :: indices
+ type (field_list_type), pointer :: field_list_cursor
+ type (field_list_type), pointer :: new_field_list_node
+ logical :: any_success
+ logical, dimension(:), pointer :: isAvailable
+
+ if (present(ierr)) ierr = MPAS_STREAM_NOERR
+
+ !
+ ! Sanity checks
+ !
+ if (.not. stream % isInitialized) then
+ if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED
+ return
+ end if
+
+!write(0,*) '... Adding field '//trim(field % fieldName)//' to stream'
+
+ ndims = size(field % dimSizes)
+
+!write(0,*) '... field has ', ndims, ' dimensions'
+
+ !
+ ! Determine whether the field is decomposed, the indices that are owned by this task's blocks,
+ ! and the total number of outer-indices owned by this task
+ !
+#include "add_field_indices.inc"
+
+
+ any_success = .false.
+ if (field % isSuperArray) then
+!write(0,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^ we are adding a super-array'
+ allocate(isAvailable(size(field % constituentNames)))
+ isAvailable(:) = .false.
+ do i=1,size(field % constituentNames)
+ call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_DOUBLE, field % dimNames(2:ndims), &
+ field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, &
+ indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ isAvailable(i) = .true.
+ any_success = .true.
+ end if
+ end do
+ else
+ nullify(isAvailable)
+ call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_DOUBLE, field % dimNames, field % dimSizes, &
+ field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err)
+ if (io_err == MPAS_STREAM_NOERR) then
+ any_success = .true.
+ end if
+ end if
+
+ deallocate(indices)
+ if (.not. any_success) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ return
+ end if
+
+ if (field % isSuperArray) then
+ do i=1,size(field % constituentNames)
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % constituentNames(i)), field % attList)
+ end do
+ else
+ call put_get_field_atts(stream % fileHandle, stream % ioDirection, trim(field % fieldname), field % attList)
+ end if
+
+
+ !
+ ! Set field pointer and type in fieldList
+ !
+ new_field_list_node => stream % fieldList
+ do while (associated(new_field_list_node % next))
+ new_field_list_node => new_field_list_node % next
+ end do
+ new_field_list_node % field_type = FIELD_5D_REAL
+ new_field_list_node % real5dField => field
+ new_field_list_node % isAvailable => isAvailable
+
+!write(0,*) '... done adding field'
+!write(0,*) 'DEBUGGING : Finished adding 3d real field '//trim(field % fieldName)
+
+ end subroutine MPAS_streamAddField_5dReal
+
+
subroutine MPAS_streamAddField_0dChar(stream, field, ierr)
implicit none
@@ -1313,6 +1521,8 @@
type (field1dReal), pointer :: field_1dreal_ptr
type (field2dReal), pointer :: field_2dreal_ptr
type (field3dReal), pointer :: field_3dreal_ptr
+ type (field4dReal), pointer :: field_4dreal_ptr
+ type (field5dReal), pointer :: field_5dreal_ptr
type (field0dChar), pointer :: field_0dchar_ptr
type (field1dChar), pointer :: field_1dchar_ptr
type (field_list_type), pointer :: field_cursor
@@ -1324,6 +1534,8 @@
real (kind=RKIND), dimension(:), pointer :: real1d_temp
real (kind=RKIND), dimension(:,:), pointer :: real2d_temp
real (kind=RKIND), dimension(:,:,:), pointer :: real3d_temp
+ real (kind=RKIND), dimension(:,:,:,:), pointer :: real4d_temp
+ real (kind=RKIND), dimension(:,:,:,:,:), pointer :: real5d_temp
if (present(ierr)) ierr = MPAS_STREAM_NOERR
@@ -1876,7 +2088,185 @@
else
deallocate(real3d_temp)
end if
+ else if (field_cursor % field_type == FIELD_4D_REAL) then
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real3dField % fieldName)
+!write(0,*) 'DEBUGGING : reading a 4d real array'
+ if (field_cursor % real4dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : reading a 4d real super-array'
+ ncons = size(field_cursor % real4dField % constituentNames)
+ allocate(real3d_temp(field_cursor % real4dField % dimSizes(2), &
+ field_cursor % real4dField % dimSizes(3), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real4d_temp(field_cursor % real4dField % dimSizes(1), &
+ field_cursor % real4dField % dimSizes(2), &
+ field_cursor % real4dField % dimSizes(3), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real4dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+!write(0,*) 'DEBUGGING : calling get_var for a constitutent'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real4dField % constituentNames(j), real3d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real4dField % fieldName, real4d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % real4dField % isSuperArray) then
+ deallocate(real3d_temp)
+ else
+ deallocate(real4d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_4dreal_ptr => field_cursor % real4dField
+ i = 1
+ do while (associated(field_4dreal_ptr))
+ if (trim(field_4dreal_ptr % dimNames(4)) == 'nCells') then
+ ownedSize = field_4dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_4dreal_ptr % dimNames(4)) == 'nEdges') then
+ ownedSize = field_4dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_4dreal_ptr % dimNames(4)) == 'nVertices') then
+ ownedSize = field_4dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_4dreal_ptr % dimSizes(4)
+ end if
+
+ if (field_cursor % real4dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : copying the temporary array'
+ field_4dreal_ptr % array(j, :,:,1:ownedSize) = real3d_temp(:,:,i:i+ownedSize-1)
+ else
+ field_4dreal_ptr % array(:,:,:,1:ownedSize) = real4d_temp(:,:,:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real3dField % isSuperArray) then
+ call mpas_dmpar_bcast_reals(field_cursor % real4dField % block % domain % dminfo, size(real3d_temp), real3d_temp(:,1,1))
+ field_4dreal_ptr => field_cursor % real4dField
+ do while (associated(field_4dreal_ptr))
+ field_4dreal_ptr % array(j,:,:,:) = real3d_temp(:,:,:)
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real4dField % block % domain % dminfo, size(real4d_temp), real4d_temp(:,1,1,1))
+ field_4dreal_ptr => field_cursor % real4dField
+ do while (associated(field_4dreal_ptr))
+ field_4dreal_ptr % array(:,:,:,:) = real4d_temp(:,:,:,:)
+ field_4dreal_ptr => field_4dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % real4dField % isSuperArray) then
+ deallocate(real3d_temp)
+ else
+ deallocate(real4d_temp)
+ end if
+
+ else if (field_cursor % field_type == FIELD_5D_REAL) then
+
+!write(0,*) 'DEBUGGING : *************** '//trim(field_cursor % real3dField % fieldName)
+!write(0,*) 'DEBUGGING : reading a 4d real array'
+ if (field_cursor % real5dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : reading a 4d real super-array'
+ ncons = size(field_cursor % real5dField % constituentNames)
+ allocate(real4d_temp(field_cursor % real5dField % dimSizes(2), &
+ field_cursor % real5dField % dimSizes(3), &
+ field_cursor % real5dField % dimSizes(4), &
+ field_cursor % totalDimSize))
+ else
+ ncons = 1
+ allocate(real5d_temp(field_cursor % real5dField % dimSizes(1), &
+ field_cursor % real5dField % dimSizes(2), &
+ field_cursor % real5dField % dimSizes(3), &
+ field_cursor % real5dField % dimSizes(4), &
+ field_cursor % totalDimSize))
+ end if
+
+ do j=1,ncons
+ if (field_cursor % real5dField % isSuperArray) then
+ if (.not. field_cursor % isAvailable(j)) cycle
+!write(0,*) 'DEBUGGING : calling get_var for a constitutent'
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real5dField % constituentNames(j), real4d_temp, io_err)
+ else
+ call MPAS_io_get_var(stream % fileHandle, field_cursor % real5dField % fieldName, real5d_temp, io_err)
+ end if
+ call MPAS_io_err_mesg(io_err, .false.)
+ if (io_err /= MPAS_IO_NOERR) then
+ if (present(ierr)) ierr = MPAS_IO_ERR
+ if (field_cursor % real5dField % isSuperArray) then
+ deallocate(real4d_temp)
+ else
+ deallocate(real5d_temp)
+ end if
+ return
+ end if
+
+ if (field_cursor % isDecomposed) then
+ ! Distribute field to multiple blocks
+ field_5dreal_ptr => field_cursor % real5dField
+ i = 1
+ do while (associated(field_5dreal_ptr))
+ if (trim(field_5dreal_ptr % dimNames(5)) == 'nCells') then
+ ownedSize = field_5dreal_ptr % block % mesh % nCellsSolve
+ else if (trim(field_5dreal_ptr % dimNames(5)) == 'nEdges') then
+ ownedSize = field_5dreal_ptr % block % mesh % nEdgesSolve
+ else if (trim(field_5dreal_ptr % dimNames(5)) == 'nVertices') then
+ ownedSize = field_5dreal_ptr % block % mesh % nVerticesSolve
+ else
+ ownedSize = field_5dreal_ptr % dimSizes(5)
+ end if
+
+ if (field_cursor % real5dField % isSuperArray) then
+!write(0,*) 'DEBUGGING : copying the temporary array'
+ field_5dreal_ptr % array(j,:,:,:,1:ownedSize) = real4d_temp(:,:,:,i:i+ownedSize-1)
+ else
+ field_5dreal_ptr % array(:,:,:,:,1:ownedSize) = real5d_temp(:,:,:,:,i:i+ownedSize-1)
+ end if
+ i = i + ownedSize
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+
+ else
+
+ if (field_cursor % real5dField % isSuperArray) then
+ call mpas_dmpar_bcast_reals(field_cursor % real5dField % block % domain % dminfo, size(real4d_temp), real4d_temp(:,1,1,1))
+ field_5dreal_ptr => field_cursor % real5dField
+ do while (associated(field_5dreal_ptr))
+ field_5dreal_ptr % array(j,:,:,:,:) = real4d_temp(:,:,:,:)
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+ else
+ call mpas_dmpar_bcast_reals(field_cursor % real5dField % block % domain % dminfo, size(real5d_temp), real5d_temp(:,1,1,1,1))
+ field_5dreal_ptr => field_cursor % real5dField
+ do while (associated(field_5dreal_ptr))
+ field_5dreal_ptr % array(:,:,:,:,:) = real5d_temp(:,:,:,:,:)
+ field_5dreal_ptr => field_5dreal_ptr % next
+ end do
+ end if
+ end if
+ end do
+
+ if (field_cursor % real5dField % isSuperArray) then
+ deallocate(real4d_temp)
+ else
+ deallocate(real5d_temp)
+ end if
+
+
else if (field_cursor % field_type == FIELD_0D_CHAR) then
!write(0,*) 'Reading in field '//trim(field_cursor % char0dField % fieldName)
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_timekeeping.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_timekeeping.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_timekeeping.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -116,6 +116,9 @@
character (len=*), intent(in) :: calendar
+#ifdef MPAS_CESM
+ TheCalendar = defaultCal % Type % caltype - 1
+#else
if (trim(calendar) == 'gregorian') then
TheCalendar = MPAS_GREGORIAN
call ESMF_Initialize(defaultCalendar=ESMF_CAL_GREGORIAN)
@@ -128,6 +131,7 @@
else
write(0,*) 'ERROR: mpas_timekeeping_init: Invalid calendar type'
end if
+#endif
end subroutine mpas_timekeeping_init
@@ -136,7 +140,9 @@
implicit none
+#ifndef MPAS_CESM
call ESMF_Finalize()
+#endif
end subroutine mpas_timekeeping_finalize
Modified: branches/ocean_projects/shared_advection/src/framework/mpas_timer.F
===================================================================
--- branches/ocean_projects/shared_advection/src/framework/mpas_timer.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/framework/mpas_timer.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -1,20 +1,15 @@
module mpas_timer
+ use mpas_kind_types
use mpas_grid_types
- use mpas_dmpar
implicit none
save
-! private
#ifdef _PAPI
include 'f90papi.h'
#endif
-!#ifdef _MPI
-! include 'mpif.h'
-!#endif
-
type timer_node
character (len=StrKIND) :: timer_name
logical :: running, printable
@@ -38,6 +33,10 @@
contains
subroutine mpas_timer_start(timer_name, clear_timer, timer_ptr)!{{{
+# ifdef _MPI
+ use mpi
+# endif
+
character (len=*), intent (in) :: timer_name !< Input: name of timer, stored as name of timer
logical, optional, intent(in) :: clear_timer !< Input: flag to clear timer
type (timer_node), optional, pointer :: timer_ptr !< Output: pointer to store timer in module
@@ -47,6 +46,10 @@
integer :: clock, hz, usecs
+#ifdef MPAS_TAU
+ call tau_start(timer_name)
+#endif
+
timer_added = .false.
timer_found = .false.
@@ -159,6 +162,10 @@
end subroutine mpas_timer_start!}}}
subroutine mpas_timer_stop(timer_name, timer_ptr)!{{{
+# ifdef _MPI
+ use mpi
+# endif
+
character (len=*), intent(in) :: timer_name !< Input: name of timer to stop
type (timer_node), pointer, optional :: timer_ptr !< Input: pointer to timer, for stopping
@@ -167,6 +174,10 @@
real (kind=RKIND) :: time_temp
logical :: timer_found, string_equal, check_flag
integer :: clock, hz, usecs
+
+#ifdef MPAS_TAU
+ call tau_stop(timer_name)
+#endif
timer_found = .false.
@@ -250,9 +261,7 @@
tname = ''
do i=0,timer_ptr%levels+2
tname = tname//' '
-! write(*,'(a,$)') ' '
end do
-! tname = tname//timer_ptr%timer_name
if(timer_ptr%total_time == 0.0d0) then
timer_ptr%min_time = 0.0d0
@@ -260,7 +269,7 @@
timer_ptr%avg_time = 0.0d0
percent = 0.0d0
else
- timer_ptr%avg_time = timer_ptr%avg_time/timer_ptr%calls
+ timer_ptr%avg_time = timer_ptr%total_time/timer_ptr%calls
percent = timer_ptr%total_time/total_ptr%total_time
endif
@@ -315,6 +324,8 @@
end subroutine mpas_timer_init!}}}
subroutine mpas_timer_sync()!{{{
+ use mpas_dmpar
+
type (timer_node), pointer :: current
real (kind=RKIND) :: all_total_time, all_max_time, all_min_time, all_ave_time
@@ -334,20 +345,12 @@
current % total_time = all_total_time
#ifdef _MPI
- if(all_total_time > 0) then
- current % efficiency = all_ave_time / all_total_time
- else
- current % efficiency = 1.0
- end if
+ current % efficiency = all_ave_time / all_total_time
#else
current % efficiency = 1.0
#endif
- if(current % calls > 0) then
- current % avg_time = current % total_time / current % calls
- else
- current % avg_time = 0.0
- end if
+ current % avg_time = current % total_time / current % calls
call mpas_dmpar_max_real(domain_info, current % max_time, all_max_time)
current % max_time = all_max_time
Modified: branches/ocean_projects/shared_advection/src/operators/mpas_tracer_advection_mono.F
===================================================================
--- branches/ocean_projects/shared_advection/src/operators/mpas_tracer_advection_mono.F 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/operators/mpas_tracer_advection_mono.F 2013-03-08 17:10:33 UTC (rev 2572)
@@ -176,7 +176,7 @@
upwind_tendency(k, iCell) = 0.0_RKIND
!tracer_new is supposed to be the "new" tracer state. This allows bounds checks.
- if (config_check_monotonicity) then
+ if (config_check_tracer_monotonicity) then
tracer_new(k,iCell) = 0.0_RKIND
end if
end do ! k loop
@@ -372,7 +372,7 @@
tend(iTracer, k, cell1) = tend(iTracer, k, cell1) - high_order_horiz_flux(k, iEdge) * invAreaCell1
tend(iTracer, k, cell2) = tend(iTracer, k, cell2) + high_order_horiz_flux(k, iEdge) * invAreaCell2
- if (config_check_monotonicity) then
+ if (config_check_tracer_monotonicity) then
!tracer_new holds a tendency for now.
tracer_new(k, cell1) = tracer_new(k, cell1) - high_order_horiz_flux(k, iEdge) * invAreaCell1
tracer_new(k, cell2) = tracer_new(k, cell2) + high_order_horiz_flux(k, iEdge) * invAreaCell2
@@ -385,7 +385,7 @@
do k = 1,maxLevelCell(iCell)
tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + verticalDivergenceFactor(k) * (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) + upwind_tendency(k,iCell)
- if (config_check_monotonicity) then
+ if (config_check_tracer_monotonicity) then
!tracer_new holds a tendency for now. Only for a check on monotonicity
tracer_new(k, iCell) = tracer_new(k, iCell) + verticalDivergenceFactor(k) * (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) + upwind_tendency(k,iCell)
@@ -395,7 +395,7 @@
end do ! k loop
end do ! iCell loop
- if (config_check_monotonicity) then
+ if (config_check_tracer_monotonicity) then
!build min and max bounds on old and new tracer for check on monotonicity.
do iCell = 1, nCellsSolve
do k = 1, maxLevelCell(iCell)
Modified: branches/ocean_projects/shared_advection/src/registry/gen_inc.c
===================================================================
--- branches/ocean_projects/shared_advection/src/registry/gen_inc.c 2013-03-07 23:46:16 UTC (rev 2571)
+++ branches/ocean_projects/shared_advection/src/registry/gen_inc.c 2013-03-08 17:10:33 UTC (rev 2572)
@@ -143,8 +143,8 @@
fortprintf(fd, " call mpas_dmpar_abort(dminfo)</font>
<font color="black">");
fortprintf(fd, " else if (ierr < 0) then</font>
<font color="black">");
fortprintf(fd, " write(0,*) \'Namelist record &%s not found; using default values for this namelist\'\'s variables\'</font>
<font color="red">",nls_ptr->record);
- fortprintf(fd, " rewind(funit)</font>
<font color="black">");
fortprintf(fd, " end if</font>
<font color="blue">");
+ fortprintf(fd, " rewind(funit)</font>
<font color="gray">");
dict_insert(dictionary, nls_ptr->record);
}
@@ -718,35 +718,37 @@
var_list_ptr3 = var_list_ptr3->next;
}
- fortprintf(fd, " allocate(%s %% %s %% array(%i, ", group_ptr->name, var_ptr2->super_array, i);
- dimlist_ptr = var_ptr2->dimlist;
- if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
- !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
- !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
- if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, "%s + 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;
- while (dimlist_ptr) {
+ if(var_ptr2->persistence == PERSISTENT){
+ 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))
- 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);
+ 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);
+ 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">");
- if (var_ptr->vtype == INTEGER)
- fortprintf(fd, " %s %% %s %% array = 0</font>
<font color="red">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
- else if (var_ptr->vtype == REAL)
- fortprintf(fd, " %s %% %s %% array = 0.0</font>
<font color="red">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
- else if (var_ptr->vtype == CHARACTER)
- fortprintf(fd, " %s %% %s %% array = \'\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
+ while (dimlist_ptr) {
+ if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
+ !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
+ if (!dimlist_ptr->dim->namelist_defined) fortprintf(fd, ", %s + 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="blue">");
+ if (var_ptr->vtype == INTEGER)
+ fortprintf(fd, " %s %% %s %% array = 0</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
+ else if (var_ptr->vtype == REAL)
+ fortprintf(fd, " %s %% %s %% array = 0.0</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
+ else if (var_ptr->vtype == CHARACTER)
+ fortprintf(fd, " %s %% %s %% array = \'\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array ); /* initialize field to zero */
+ }
fortprintf(fd, " %s %% %s %% dimSizes(1) = %i</font>
<font color="black">", group_ptr->name, var_ptr2->super_array, i);
fortprintf(fd, " %s %% %s %% dimNames(1) = \'num_%s\'</font>
<font color="gray">", group_ptr->name, var_ptr2->super_array, var_ptr2->super_array);
@@ -757,8 +759,14 @@
!strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
!strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
if (!dimlist_ptr->dim->namelist_defined) {
- fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="red">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_code);
- fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ if (var_ptr2->persistence == PERSISTENT){
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ }
+ else {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s+1</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
+ }
}
else {
fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="gray">", group_ptr->name, var_ptr2->super_array, i, dimlist_ptr->dim->name_in_file);
@@ -813,6 +821,9 @@
fortprintf(fd, " %s %% %s %% fieldName = \'%s\'</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_file);
fortprintf(fd, " %s %% %s %% isSuperArray = .false.</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
if (var_ptr->ndims > 0) {
+ if(var_ptr->persistence == SCRATCH){
+ fortprintf(fd, " nullify(%s %% %s %% array)</font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code);
+ } else if(var_ptr->persistence == PERSISTENT){
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) ||
@@ -843,6 +854,7 @@
else if (var_ptr->vtype == CHARACTER)
fortprintf(fd, " %s %% %s %% array = \'\'</font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code ); /* initialize field to zero */
+ }
dimlist_ptr = var_ptr->dimlist;
i = 1;
while (dimlist_ptr) {
@@ -850,8 +862,14 @@
!strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) ||
!strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024))
if (!dimlist_ptr->dim->namelist_defined) {
- fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="red">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_code);
- fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ if(var_ptr->persistence == PERSISTENT){
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ }
+ else {
+ fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s+1</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_code);
+ fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
+ }
}
else {
fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s</font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file);
@@ -869,7 +887,7 @@
i++;
dimlist_ptr = dimlist_ptr->next;
}
- }
+ }
if (var_ptr->timedim) fortprintf(fd, " %s %% %s %% hasTimeDimension = .true.</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
else fortprintf(fd, " %s %% %s %% hasTimeDimension = .false.</font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code);
@@ -934,14 +952,18 @@
var_list_ptr2 = var_list_ptr;
var_list_ptr = var_list_ptr->next;
}
- fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="blue">", group_ptr->name, var_list_ptr2->var->super_array);
+ fortprintf(fd, " if(associated(%s %% %s %% array)) then</font>
<font color="blue">", group_ptr->name, var_list_ptr2->var->super_array);
+ fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="blue">", group_ptr->name, var_list_ptr2->var->super_array);
+ fortprintf(fd, " end if</font>
<font color="black">");
fortprintf(fd, " deallocate(%s %% %s %% ioinfo)</font>
<font color="black">", group_ptr->name, var_list_ptr2->var->super_array);
fortprintf(fd, " call mpas_deallocate_attlist(%s %% %s %% attList)</font>
<font color="black">", group_ptr->name, var_list_ptr2->var->super_array);
fortprintf(fd, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="red">", group_ptr->name, var_list_ptr2->var->super_array);
}
else {
if (var_ptr->ndims > 0) {
- fortprintf(fd, " deallocate(%s %% %s %% array)</font>
<font color="blue">", group_ptr->name, var_ptr->name_in_code);
+ fortprintf(fd, " if(associated(%s %% %s %% array)) then</font>
<font color="blue">", group_ptr->name, 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, " end if</font>
<font color="black">");
fortprintf(fd, " deallocate(%s %% %s %% ioinfo)</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, " call mpas_deallocate_attlist(%s %% %s %% attList)</font>
<font color="black">", group_ptr->name, var_ptr->name_in_code);
fortprintf(fd, " deallocate(%s %% %s)</font>
<font color="black"></font>
<font color="gray">", group_ptr->name, var_ptr->name_in_code);
@@ -990,10 +1012,12 @@
fortprintf(fd, " dest %% %s %% scalar = src %% %s %% scalar</font>
<font color="blue">", var_ptr2->super_array, var_ptr2->super_array);
}
else {
+ if (var_ptr->persistence == PERSISTENT){
if (var_ptr->ndims > 0)
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="gray">", var_ptr->name_in_code, var_ptr->name_in_code);
+ }
var_list_ptr = var_list_ptr->next;
}
}
@@ -1110,8 +1134,10 @@
{
var_list_ptr = group_ptr->vlist;
var_list_ptr = var_list_ptr->next;
+
+ if (!var_list_ptr) break;
+
var_ptr = var_list_ptr->var;
-
int ntime_levs = 1;
@@ -2126,6 +2152,7 @@
dimlist_ptr = var_ptr->dimlist;
i = 1;
+ if(var_ptr->persistence == PERSISTENT){
while (dimlist_ptr) {
if (i == var_ptr->ndims) {
@@ -2172,6 +2199,7 @@
i++;
dimlist_ptr = dimlist_ptr -> next;
}
+ }
if (var_list_ptr) var_list_ptr = var_list_ptr->next;
}
</font>
</pre>