diff --git a/.gitignore b/.gitignore index a90e1bcc04..9e8657b967 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ # Ignore Files in the MPAS Direcory # All pre-processed Fortran files in MPAS specific directories +src/core_*/Registry_processed.xml src/core_*/*.f90 src/framework/*.f90 src/driver/*.f90 @@ -44,3 +45,12 @@ src/registry/parse # Ignore MPAS core build files. .mpas_core_* + +# Ignore all runtime config files +namelist.* +streams.* +stream_list.* + +# Intermediate files that may be produced by Intel compilers +*.i +*.i90 diff --git a/Makefile b/Makefile index 44afbed093..4c09dfcdf7 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,4 @@ -#MODEL_FORMULATION = -DNCAR_FORMULATION -MODEL_FORMULATION = -DLANL_FORMULATION +MODEL_FORMULATION = dummy: @@ -36,6 +35,20 @@ ftn: "USE_PAPI = $(USE_PAPI)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) +titan-cray: + ( $(MAKE) all \ + "FC_PARALLEL = ftn" \ + "CC_PARALLEL = cc" \ + "FC_SERIAL = ftn" \ + "CC_SERIAL = gcc" \ + "FFLAGS_OPT = -s integer32 -default64 -O3 -f free -N 255 -em -ef" \ + "CFLAGS_OPT = -O3" \ + "LDFLAGS_OPT = -O3" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + pgi: ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ @@ -108,7 +121,7 @@ ifort-gcc: "CFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -FR -CU -CB -check all -fpe0 -traceback" \ - "CFLAGS_DEBUG = -g -traceback" \ + "CFLAGS_DEBUG = -g" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ @@ -197,7 +210,7 @@ intel-nersc: "CC_PARALLEL = cc" \ "FC_SERIAL = ftn" \ "CC_SERIAL = cc" \ - "FFLAGS_OPT = -real-size 64 -O3 -FR" \ + "FFLAGS_OPT = -real-size 64 -O3 -convert big_endian -FR" \ "CFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ "CORE = $(CORE)" \ @@ -226,29 +239,57 @@ CPPINCLUDES = FCINCLUDES = LIBS = ifneq ($(wildcard $(PIO)/lib), ) # Check for newer PIO version - CPPINCLUDES = -I$(NETCDF)/include -I$(PIO)/include -I$(PNETCDF)/include - FCINCLUDES = -I$(NETCDF)/include -I$(PIO)/include -I$(PNETCDF)/include - LIBS = -L$(PIO)/lib -L$(PNETCDF)/lib -L$(NETCDF)/lib -lpio -lpnetcdf + CPPINCLUDES = -I$(PIO)/include + FCINCLUDES = -I$(PIO)/include + LIBS = -L$(PIO)/lib -lpio else - CPPINCLUDES = -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include - FCINCLUDES = -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include - LIBS = -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -lpio -lpnetcdf + CPPINCLUDES = -I$(PIO) + FCINCLUDES = -I$(PIO) + LIBS = -L$(PIO) -lpio endif -NCLIB = -lnetcdf -NCLIBF = -lnetcdff -ifneq ($(wildcard $(NETCDF)/lib/libnetcdff.*), ) # CHECK FOR NETCDF4 - LIBS += $(NCLIBF) -endif # CHECK FOR NETCDF4 -LIBS += $(NCLIB) +ifneq "$(PNETCDF)" "" + CPPINCLUDES += -I$(PNETCDF)/include + FCINCLUDES += -I$(PNETCDF)/include + LIBS += -L$(PNETCDF)/lib -lpnetcdf +endif + +ifneq "$(NETCDF)" "" + CPPINCLUDES += -I$(NETCDF)/include + FCINCLUDES += -I$(NETCDF)/include + LIBS += -L$(NETCDF)/lib + NCLIB = -lnetcdf + NCLIBF = -lnetcdff + ifneq ($(wildcard $(NETCDF)/lib/libnetcdff.*), ) # CHECK FOR NETCDF4 + LIBS += $(NCLIBF) + endif # CHECK FOR NETCDF4 + LIBS += $(NCLIB) +endif RM = rm -f CPP = cpp -P -traditional RANLIB = ranlib - ifdef CORE +ifneq ($(wildcard src/core_$(CORE)), ) # CHECK FOR EXISTENCE OF CORE DIRECTORY + +ifneq ($(wildcard src/core_$(CORE)/build_options.mk), ) # Check for build_options.mk +include src/core_$(CORE)/build_options.mk +else # ELSE Use Default Options +EXE_NAME=$(CORE)_model +NAMELIST_SUFFIX=$(CORE) +endif + +override CPPFLAGS += -DMPAS_NAMELIST_SUFFIX=$(NAMELIST_SUFFIX) +override CPPFLAGS += -DMPAS_EXE_NAME=$(EXE_NAME) + +else # ELSE CORE DIRECTORY CHECK + +report_builds: all + +endif # END CORE DIRECTORY CHECK + ifeq "$(DEBUG)" "true" ifndef FFLAGS_DEBUG @@ -302,7 +343,6 @@ else GEN_F90_MESSAGE="MPAS was built with .F files." endif - ifneq ($(wildcard .mpas_core_*), ) # CHECK FOR BUILT CORE ifneq ($(wildcard .mpas_core_$(CORE)), ) # CHECK FOR SAME CORE AS ATTEMPTED BUILD. @@ -326,10 +366,32 @@ else CONTINUE=true endif # END IF BUILT CORE CHECK +ifneq ($(wildcard namelist.$(NAMELIST_SUFFIX)), ) # Check for generated namelist file. + NAMELIST_MESSAGE="A default namelist file (namelist.$(NAMELIST_SUFFIX).defaults) has been generated, but namelist.$(NAMELIST_SUFFIX) has not been modified." +else + NAMELIST_MESSAGE="A default namelist file (namelist.$(NAMELIST_SUFFIX).defaults) has been generated and copied to namelist.$(NAMELIST_SUFFIX)." +endif + +ifneq ($(wildcard streams.$(NAMELIST_SUFFIX)), ) # Check for generated streams file. + STREAM_MESSAGE="A default streams file (streams.$(NAMELIST_SUFFIX).defaults) has been generated, but streams.$(NAMELIST_SUFFIX) has not been modified." +else + STREAM_MESSAGE="A default streams file (streams.$(NAMELIST_SUFFIX).defaults) has been generated and copied to streams.$(NAMELIST_SUFFIX)." +endif + + ifeq "$(findstring clean, $(MAKECMDGOALS))" "clean" # CHECK FOR CLEAN TARGET override AUTOCLEAN=false endif # END OF CLEAN TARGET CHECK +VER=$(shell git describe --dirty 2> /dev/null) +#override CPPFLAGS += -DMPAS_GIT_VERSION=$(VER) + +ifeq "$(findstring v, $(VER))" "v" + override CPPFLAGS += -DMPAS_GIT_VERSION=$(VER) +else + override CPPFLAGS += -DMPAS_GIT_VERSION="unknown" +endif # END OF GIT DESCRIBE VERSION + #################################################### # Section for adding external libraries and includes #################################################### @@ -348,6 +410,11 @@ all: core_error else +ifeq ($(wildcard src/core_$(CORE)/build_options.mk), ) # Check for build_options.mk +report_builds: + @echo "CORE=$(CORE)" +endif + ifeq "$(CONTINUE)" "true" all: mpas_main else @@ -356,7 +423,8 @@ endif endif -mpas_main: + +mpas_main: ifeq "$(AUTOCLEAN)" "true" $(RM) .mpas_core_* endif @@ -376,10 +444,17 @@ endif FCINCLUDES="$(FCINCLUDES)" \ CORE="$(CORE)"\ AUTOCLEAN="$(AUTOCLEAN)" \ - GEN_F90="$(GEN_F90)" - @echo "$(CORE)" > .mpas_core_$(CORE) - if [ -e src/$(CORE)_model ]; then mv src/$(CORE)_model .; fi - @echo "" + GEN_F90="$(GEN_F90)" \ + NAMELIST_SUFFIX="$(NAMELIST_SUFFIX)" \ + EXE_NAME="$(EXE_NAME)" + + @echo "$(EXE_NAME)" > .mpas_core_$(CORE) + if [ -e src/$(EXE_NAME) ]; then mv src/$(EXE_NAME) .; fi + if [ -e src/inc/namelist.$(NAMELIST_SUFFIX).defaults ]; then mv src/inc/namelist.$(NAMELIST_SUFFIX).defaults .; fi + if [ ! -e namelist.$(NAMELIST_SUFFIX) ]; then cp namelist.$(NAMELIST_SUFFIX).defaults namelist.$(NAMELIST_SUFFIX); fi + if [ -e src/inc/streams.$(NAMELIST_SUFFIX).defaults ]; then mv src/inc/streams.$(NAMELIST_SUFFIX).defaults .; fi + if [ ! -e streams.$(NAMELIST_SUFFIX) ]; then cp streams.$(NAMELIST_SUFFIX).defaults streams.$(NAMELIST_SUFFIX); fi + for f in `find src/inc -name "stream_list.*"`; do mv $$f .; done @echo "*******************************************************************************" @echo $(DEBUG_MESSAGE) @echo $(PARALLEL_MESSAGE) @@ -389,11 +464,15 @@ ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) endif @echo $(GEN_F90_MESSAGE) + @echo $(NAMELIST_MESSAGE) + @echo $(STREAM_MESSAGE) @echo "*******************************************************************************" clean: - $(RM) .mpas_core_* cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)" - $(RM) $(CORE)_model + $(RM) .mpas_core_* + $(RM) $(EXE_NAME) + $(RM) namelist.$(NAMELIST_SUFFIX).defaults + $(RM) streams.$(NAMELIST_SUFFIX).defaults core_error: @echo "" @echo "*******************************************************************************" diff --git a/README.md b/README.md index 2e4d6659a6..8a55d47dd8 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v2.1 +MPAS-v3.0 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for diff --git a/namelist.input b/namelist.input deleted file mode 120000 index dbb22ae880..0000000000 --- a/namelist.input +++ /dev/null @@ -1 +0,0 @@ -namelist.input.sw \ No newline at end of file diff --git a/namelist.input.atmosphere b/namelist.input.atmosphere deleted file mode 100644 index 7a9b742c56..0000000000 --- a/namelist.input.atmosphere +++ /dev/null @@ -1,85 +0,0 @@ -&nhyd_model - config_dt = 450.0 - 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 = 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_visc4_2dsmag = 0.05 - config_u_vadv_order = 3 - config_w_vadv_order = 3 - config_theta_vadv_order = 3 - config_scalar_vadv_order = 3 - config_w_adv_order = 3 - config_theta_adv_order = 3 - config_scalar_adv_order = 3 - config_scalar_advection = .true. - config_positive_definite = .false. - config_monotonic = .true. - config_coef_3rd_order = 0.25 - config_epssm = 0.1 - config_smdiv = 0.1 - config_h_ScaleWithMesh = .true. - config_newpx = .false. -/ - config_stop_time = '0000-01-16_00:00:00' - -&damping - config_zd = 22000.0 - config_xnutr = 0.2 -/ - -&io - config_input_name = 'x1.40962.init.nc' - config_output_name = 'x1.40962.output.nc' - config_output_interval = '1_00:00:00' - config_restart_name = 'x1.40962.restart.nc' - config_restart_interval = '1_00:00:00' - config_sfc_update_name = 'x1.40962.sfc_update.nc' - config_sfc_update_interval = 'none' - config_hifreq_output_interval = 'none' - config_frames_per_outfile = 1 - config_pio_num_iotasks = 0 - config_pio_stride = 1 -/ - -&decomposition - config_block_decomp_file_prefix = 'x1.40962.graph.info.part.' -/ - -&restart - config_do_restart = .false. -/ - -&physics - config_frac_seaice = .false. - config_sfc_albedo = .true. - config_sfc_snowalbedo = .true. - config_sst_update = .false. - config_sstdiurn_update = .false. - config_deepsoiltemp_update = .false. - config_bucket_update = 'none' - config_bucket_rainc = 100.0 - config_bucket_rainnc = 100.0 - config_bucket_radt = 1.0e9 - config_radtlw_interval = '00:30:00' - config_radtsw_interval = '00:30:00' - config_conv_interval = 'none' - config_pbl_interval = 'none' - config_n_microp = 1 - config_microp_scheme = 'wsm6' - config_conv_deep_scheme = 'kain_fritsch' - config_lsm_scheme = 'noah' - config_pbl_scheme = 'ysu' - config_gwdo_scheme = 'off' - config_radt_cld_scheme = 'cld_incidence' - config_radt_lw_scheme = 'rrtmg_lw' - config_radt_sw_scheme = 'rrtmg_sw' - config_sfclayer_scheme = 'monin_obukhov' -/ diff --git a/namelist.input.init_atmosphere b/namelist.input.init_atmosphere deleted file mode 100644 index c21ca29046..0000000000 --- a/namelist.input.init_atmosphere +++ /dev/null @@ -1,48 +0,0 @@ -&nhyd_model - config_init_case = 7 - config_theta_adv_order = 3 - config_start_time = '2010-10-23_00:00:00' - config_stop_time = '2010-10-23_00:00:00' -/ - -&dimensions - config_nvertlevels = 41 - config_nsoillevels = 4 - config_nfglevels = 38 - config_nfgsoillevels = 4 -/ - -&data_sources - config_geog_data_path = '/glade/p/work/wrfhelp/WPS_GEOG/' - config_met_prefix = 'CFSR' - config_sfc_prefix = 'SST' - config_fg_interval = 21600 -/ - -&vertical_grid - config_ztop = 30000.0 - config_nsmterrain = 1 - config_smooth_surfaces = .true. -/ - -&preproc_stages - config_static_interp = .true. - config_vertical_grid = .true. - config_met_interp = .true. - config_input_sst = .false. -/ - -&io - config_input_name = 'grid.nc' - config_output_name = 'init.nc' - config_sfc_update_name = 'sfc_update.nc' - config_pio_num_iotasks = 0 - config_pio_stride = 1 -/ - -&decomposition - config_block_decomp_file_prefix = 'graph.info.part.' -/ - -&restart -/ diff --git a/namelist.input.landice b/namelist.input.landice deleted file mode 100644 index 9b2ec1faf2..0000000000 --- a/namelist.input.landice +++ /dev/null @@ -1,51 +0,0 @@ -&velocity_solver - config_velocity_solver = "sia" -/ -&advection - config_thickness_advection = "fo" - config_tracer_advection = "none" -/ -&physical_parameters - config_ice_density = 910.0 - config_ocean_density = 1028.0 - config_sea_level = 0.0 - config_default_flowParamA = 3.1709792e-24 - config_flowLawExponent = 3.0 - config_dynamic_thickness = 100.0 -/ -&time_integration - config_dt_years = 0.5 - config_dt_seconds = 0.0 - config_time_integration = "forward_euler" -/ -&time_management - config_do_restart = .false. - config_start_time = "0000-01-01_00:00:00" - config_stop_time = "0000-01-01_00:00:00" - config_run_duration = "none" - config_calendar_type = "gregorian_noleap" -/ -&io - config_input_name = "landice_grid.nc" - config_output_name = "output.nc" - config_restart_name = "restart.nc" - config_restart_timestamp_name = "restart_timestamp" - config_restart_interval = "3650_00:00:00" - config_output_interval = "0001_00:00:00" - config_stats_interval = "0000_01:00:00" - config_write_stats_on_startup = .true. - config_write_output_on_startup = .true. - config_frames_per_outfile = 0 - config_pio_num_iotasks = 0 - config_pio_stride = 1 -/ -&decomposition - config_num_halos = 3 - 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." -/ -&debug - config_print_thickness_advection_info = .false. -/ diff --git a/namelist.input.ocean b/namelist.input.ocean deleted file mode 100644 index eebfcf6a57..0000000000 --- a/namelist.input.ocean +++ /dev/null @@ -1,212 +0,0 @@ -&time_management - config_do_restart = .false. - config_start_time = "0000-01-01_00:00:00" - config_stop_time = "none" - config_run_duration = "0001_00:00:00" - config_calendar_type = "360day" -/ -&io - config_input_name = "grid.nc" - config_output_name = "output.nc" - config_restart_name = "restart.nc" - config_restart_timestamp_name = "restart_timestamp" - config_restart_interval = "0001_00:00:00" - config_output_interval = "0001_00:00:00" - config_stats_interval = "0000_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 -/ -&time_integration - config_dt = 300.0 - config_time_integrator = "split_explicit" -/ -&ALE_vertical_grid - config_vert_coord_movement = "uniform_stretching" - config_use_min_max_thickness = .false. - config_min_thickness = 1.0 - config_max_thickness_factor = 6.0 - config_set_restingThickness_to_IC = .true. - config_dzdk_positive = .false. -/ -&ALE_frequency_filtered_thickness - config_use_freq_filtered_thickness = .false. - config_thickness_filter_timescale = 5.0 - config_use_highFreqThick_restore = .false. - config_highFreqThick_restore_time = 30.0 - config_use_highFreqThick_del2 = .false. - config_highFreqThick_del2 = 100.0 -/ -&partial_bottom_cells - config_alter_ICs_for_pbcs = .false. - config_pbc_alteration_type = "full_cell" - config_min_pbc_fraction = 0.10 - config_check_ssh_consistency = .true. -/ -&decomposition - config_num_halos = 3 - 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_hmix_ScaleWithMesh = .false. - config_maxMeshDensity = -1.0 - config_apvm_scale_factor = 0.0 -/ -&hmix_del2 - config_use_mom_del2 = .true. - config_use_tracer_del2 = .false. - config_mom_del2 = 10.0 - config_tracer_del2 = 10.0 -/ -&hmix_del4 - config_use_mom_del4 = .false. - config_use_tracer_del4 = .false. - config_mom_del4 = 5.0e13 - config_tracer_del4 = 0.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 -/ -&hmix_del2_tensor - config_use_mom_del2_tensor = .false. - config_mom_del2_tensor = 10.0 -/ -&hmix_del4_tensor - config_use_mom_del4_tensor = .false. - config_mom_del4_tensor = 5.0e13 -/ -&Rayleigh_damping - config_Rayleigh_friction = .false. - config_Rayleigh_damping_coeff = 0.0 -/ -&vmix - config_convective_visc = 1.0 - config_convective_diff = 1.0 -/ -&vmix_const - config_use_const_visc = .true. - config_use_const_diff = .true. - config_vert_visc = 1.0e-4 - config_vert_diff = 1.0e-4 -/ -&vmix_rich - 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_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 -/ -&cvmix - config_use_cvmix = .false. - config_cvmix_prandtl_number = 1.0 - config_use_cvmix_background = .false. - config_cvmix_background_diffusion = 1.0e-5 - config_cvmix_background_viscosity = 1.0e-4 - config_use_cvmix_convection = .false. - config_cvmix_convective_diffusion = 1.0 - config_cvmix_convective_viscosity = 1.0 - config_use_cvmix_kpp = .false. - config_cvmix_kpp_criticalBulkRichardsonNumber = 0.25 - config_cvmix_kpp_interpolationOMLType = "quadratic" -/ -&forcing - config_forcing_type = "off" - config_restoreT_timescale = 90.0 - config_restoreS_timescale = 90.0 - config_restoreT_lengthscale = 50.0 - config_restoreS_lengthscale = 50.0 - config_flux_attenuation_coefficient = 0.001 - config_frazil_ice_formation = .true. - config_sw_absorption_type = "jerlov" - config_jerlov_water_type = 3 - config_fixed_jerlov_weights = .true. -/ -&advection - 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. -/ -&bottom_drag - config_bottom_drag_coeff = 1.0e-2 -/ -&pressure_gradient - config_pressure_gradient_type = "pressure_and_zmid" - config_density0 = 1014.65 -/ -&eos - config_eos_type = "linear" -/ -&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_densityref = 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_vel_correction = .true. - config_btr_subcycle_loop_factor = 2 - config_btr_gam1_velWt1 = 0.5 - config_btr_gam2_SSHWt1 = 1.0 - config_btr_gam3_velWt2 = 1.0 - config_btr_solve_SSH2 = .false. -/ -&testing - config_conduct_tests = .false. - config_test_tensors = .false. - config_tensor_test_function = "sph_uCosCos" -/ -&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_thick_all_tend = .false. - config_disable_thick_hadv = .false. - config_disable_thick_vadv = .false. - config_disable_thick_sflux = .false. - config_disable_vel_all_tend = .false. - config_disable_vel_coriolis = .false. - config_disable_vel_pgrad = .false. - config_disable_vel_hmix = .false. - config_disable_vel_windstress = .false. - config_disable_vel_vmix = .false. - config_disable_vel_vadv = .false. - config_disable_tr_all_tend = .false. - config_disable_tr_adv = .false. - config_disable_tr_hmix = .false. - config_disable_tr_vmix = .false. - config_disable_tr_sflux = .false. -/ diff --git a/namelist.input.sw b/namelist.input.sw deleted file mode 100644 index 7eca943bfc..0000000000 --- a/namelist.input.sw +++ /dev/null @@ -1,40 +0,0 @@ -&sw_model - config_test_case = 5 - config_time_integration = 'RK4' - config_dt = 172.8 - config_start_time = '0000-01-01_00:00:00' - config_run_duration = '15_00:00:00' - config_stats_interval = 0 - config_h_ScaleWithMesh = .false. - config_h_mom_eddy_visc2 = 0.0 - config_h_mom_eddy_visc4 = 0.0 - config_h_tracer_eddy_diff2 = 0.0 - config_h_tracer_eddy_diff4 = 0.0 - config_thickness_adv_order = 2 - config_tracer_adv_order = 2 - config_positive_definite = .false. - config_monotonic = .false. - config_wind_stress = .false. - config_bottom_drag = .false. -/ - config_stop_time = '0000-01-16_00:00:00' - -&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 = 0 - config_pio_num_iotasks = 0 - config_pio_stride = 1 -/ -&decomposition - config_number_of_blocks = 0 - config_block_decomp_file_prefix = 'graph.info.part.' - config_explicit_proc_decomp = .false. - config_proc_decomp_file_prefix = 'graph.info.part.' -/ -&restart - config_restart_interval = '15_00:00:00' - config_do_restart = .false. -/ diff --git a/src/Makefile b/src/Makefile index 63eb2a92c8..7132f6ec10 100644 --- a/src/Makefile +++ b/src/Makefile @@ -17,7 +17,7 @@ endif all: mpas mpas: $(AUTOCLEAN_DEPS) reg_includes externals frame ops dycore drver - $(LINKER) $(LDFLAGS) -o $(CORE)_model driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time + $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time externals: $(AUTOCLEAN_DEPS) reg_includes ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" ) @@ -26,9 +26,12 @@ drver: $(AUTOCLEAN_DEPS) reg_includes externals frame ops dycore ( cd driver; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all ) endif -reg_includes: $(AUTOCLEAN_DEPS) - ( cd registry; $(MAKE) CC="$(SCC)" ) - ( cd inc; $(CPP) $(CPPFLAGS) $(CPPINCLUDES) ../core_$(CORE)/Registry.xml | ../registry/parse ) +reg_includes: core_reg $(AUTOCLEAN_DEPS) + ( cd registry; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CC="$(SCC)" ) + ( cd inc; ../registry/parse < ../core_$(CORE)/Registry_processed.xml) + +core_reg: + (cd core_$(CORE); $(MAKE) core_reg ) frame: $(AUTOCLEAN_DEPS) reg_includes externals ( cd framework; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all ) diff --git a/src/Makefile.in.CESM_OCN b/src/Makefile.in.CESM_OCN index 55806cae70..d361600652 100644 --- a/src/Makefile.in.CESM_OCN +++ b/src/Makefile.in.CESM_OCN @@ -1,4 +1,11 @@ include $(CASEROOT)/Macros + +ifeq ($(strip $(USE_ESMF_LIB)), TRUE) + ESMFDIR = esmf +else + ESMFDIR = noesmf +endif + RM = rm -f CPP = cpp -C -P -traditional FC=$(MPIFC) @@ -10,9 +17,9 @@ FILE_OFFSET = -DOFFSET64BIT CFLAGS += -DMPAS_CESM FFLAGS += -DMPAS_CESM 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)/lib/include -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include -LIBS += -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -lpio -lpnetcdf -lnetcdf +CPPINCLUDES += -I$(EXEROOT)/ocn/source/inc -I$(SHAREDPATH)/include -I$(SHAREDPATH)/$(COMP_INTERFACE)/$(ESMFDIR)/$(NINST_VALUE)/csm_share -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include +FCINCLUDES += -I$(EXEROOT)/ocn/source/inc -I$(SHAREDPATH)/include -I$(SHAREDPATH)/$(COMP_INTERFACE)/$(ESMFDIR)/$(NINST_VALUE)/csm_share -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include +LIBS += -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -L$(LIBROOT) -L$(SHAREDPATH)/lib -lpio -lpnetcdf -lnetcdf all: @echo $(CPPINCLUDES) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 6d1377ee3d..6409bc87cf 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -8,6 +8,9 @@ OBJS = mpas_atm_mpas_core.o \ all: physcore dycore atmcore +core_reg: + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml + physcore: ( cd physics; $(MAKE) all ) ( mkdir libphys; cd libphys; ar -x ../physics/libphys.a ) @@ -29,6 +32,10 @@ clean: ( cd ../..; rm -f *DATA* ) $(RM) -r libphys $(RM) *.o *.mod *.f90 libdycore.a + $(RM) Registry_processed.xml + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: $(RM) $@ $*.mod diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 81436ec8c2..885adcc71f 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -33,23 +33,24 @@ - - - - - - - - + + + + + + + + - - - + + + + @@ -57,152 +58,699 @@ - - - + + - + - + - + - + - - - - - - - - - - - + + - + - - - - - + + + + + - + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - + + + - - + + - - - - - - - - - - - - - + + + + + + + + + + + + - + - - - + + + - - + - - + + - - - + + + @@ -210,21 +758,21 @@ - + - - - - + + + + - - - - - - + + + + + + @@ -257,44 +805,45 @@ - + - - - - - - - - - - - + + + + + + + + + + + - - - - - + + + + + - - + + - + - - - - - - + + + + + + + @@ -302,78 +851,81 @@ - - + + - - + + - + - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - + + + + + + + + - - - - - - - + + + + + + + @@ -385,57 +937,56 @@ - + - - - - - + + + + - - - + + + - - - + + + - + - + - - - - - - + + + + + + - - - - + + + + - - - - - - - - + + + + + + + + - + @@ -447,13 +998,13 @@ - - + + - - - - + + + + @@ -467,23 +1018,23 @@ - - + + - + - - - - - + + + + + - - - + + + - - + + @@ -493,10 +1044,10 @@ - - - - + + + + @@ -504,10 +1055,10 @@ - - - - + + + + @@ -517,14 +1068,14 @@ - - - + + + - - - + + + @@ -567,44 +1118,44 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - + + + + + @@ -616,13 +1167,13 @@ - - - - + + + + - - + + @@ -661,40 +1212,40 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - + + + + @@ -741,43 +1292,43 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - + + + + @@ -794,15 +1345,15 @@ - - + + - + @@ -835,31 +1386,31 @@ - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + @@ -872,25 +1423,25 @@ - - - - + + + + - - + + - - - + + + @@ -903,12 +1454,12 @@ - - - - - - + + + + + + @@ -917,17 +1468,17 @@ - - + + - + - - + + - + @@ -937,6 +1488,7 @@ + @@ -960,33 +1512,34 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -1003,15 +1556,15 @@ - - - - - - - - - - + + + + + + + + + + diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 8be1daae40..7b705bea62 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -1,16 +1,17 @@ .SUFFIXES: .F .o -OBJS = mpas_atm_time_integration.o \ - mpas_atm_advection.o +OBJS = mpas_atm_time_integration.o all: $(OBJS) mpas_atm_time_integration.o: -mpas_atm_advection.o: clean: $(RM) *.o *.mod *.f90 + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: $(RM) $@ $*.mod diff --git a/src/core_atmosphere/dynamics/mpas_atm_advection.F b/src/core_atmosphere/dynamics/mpas_atm_advection.F deleted file mode 100644 index 5e3068c01f..0000000000 --- a/src/core_atmosphere/dynamics/mpas_atm_advection.F +++ /dev/null @@ -1,939 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -module atm_advection - - use mpas_kind_types - use mpas_grid_types - use mpas_configure - use mpas_constants - - - contains - - - subroutine atm_initialize_advection_rk( grid ) - -! -! compute the cell coefficients for the polynomial fit. -! this is performed during setup for model integration. -! WCS, 31 August 2009 -! - implicit none - - type (mesh_type), intent(in) :: grid - - real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two - integer, dimension(:,:), pointer :: advCells - -! local variables - - real (kind=RKIND), dimension(2, grid % nEdges) :: thetae - real (kind=RKIND), dimension(grid % nCells) :: theta_abs - - real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates - real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere - real (kind=RKIND) :: xec, yec, zec - real (kind=RKIND) :: thetae_tmp - real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2 - integer :: i, j, k, ip1, ip2, n - integer :: iCell, iEdge - real (kind=RKIND) :: pii - real (kind=RKIND), dimension(25) :: xp, yp - - real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25) - real (kind=RKIND) :: length_scale - integer :: ma,na, cell_add, mw - integer, dimension(25) :: cell_list - logical :: add_the_cell, do_the_cell - - real (kind=RKIND) :: cos2t, costsint, sin2t - real (kind=RKIND), dimension(grid%maxEdges) :: angle_2d - - integer, parameter :: polynomial_order = 2 - logical, parameter :: debug = .false. - logical, parameter :: least_squares = .true. - logical, parameter :: reset_poly = .true. - - - pii = 2.*asin(1.0) - - advCells => grid % advCells % array - deriv_two => grid % deriv_two % array - deriv_two(:,:,:) = 0. - - do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also... - - cell_list(1) = iCell - do i=2, grid % nEdgesOnCell % array(iCell)+1 - cell_list(i) = grid % CellsOnCell % array(i-1,iCell) - end do - n = grid % nEdgesOnCell % array(iCell) + 1 - - if ( polynomial_order > 2 ) then - do i=2,grid % nEdgesOnCell % array(iCell) + 1 - do j=1,grid % nEdgesOnCell % array ( cell_list(i) ) - cell_add = grid % CellsOnCell % array (j,cell_list(i)) - add_the_cell = .true. - do k=1,n - if ( cell_add == cell_list(k) ) add_the_cell = .false. - end do - if (add_the_cell) then - n = n+1 - cell_list(n) = cell_add - end if - end do - end do - end if - - advCells(1,iCell) = n - -! check to see if we are reaching outside the halo - - do_the_cell = .true. - do i=1,n - if (cell_list(i) > grid % nCells) do_the_cell = .false. - end do - - - if ( .not. do_the_cell ) cycle - - -! compute poynomial fit for this cell if all needed neighbors exist - if ( grid % on_a_sphere ) then - - do i=1,n - advCells(i+1,iCell) = cell_list(i) - 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 - - ! - ! In case the current cell center lies at exactly z=1.0, the sphere_angle() routine - ! may generate an FPE since the triangle it is given will have a zero side length - ! adjacent to the vertex whose angle we are trying to find; in this case, simply - ! set the value of theta_abs directly - ! - if (zc(1) == 1.0) then - theta_abs(iCell) = pii/2. - else - theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), & - xc(2), yc(2), zc(2), & - 0.0_RKIND, 0.0_RKIND, 1.0_RKIND ) - end if - -! angles from cell center to neighbor centers (thetav) - - do i=1,n-1 - - ip2 = i+2 - if (ip2 > n) ip2 = 2 - - thetav(i) = sphere_angle( xc(1), yc(1), zc(1), & - xc(i+1), yc(i+1), zc(i+1), & - xc(ip2), yc(ip2), zc(ip2) ) - - 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. - do i=1,n-1 - dl_sphere(i) = dl_sphere(i)/length_scale - end do - -! thetat(1) = 0. ! this defines the x direction, cell center 1 -> - thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line - do i=2,n-1 - thetat(i) = thetat(i-1) + thetav(i-1) - end do - - do i=1,n-1 - xp(i) = cos(thetat(i)) * dl_sphere(i) - yp(i) = sin(thetat(i)) * dl_sphere(i) - end do - - else ! On an x-y plane - - do i=1,n-1 - - angle_2d(i) = grid%angleEdge%array(grid % EdgesOnCell % array(i,iCell)) - iEdge = grid % EdgesOnCell % array(i,iCell) - if ( iCell .ne. grid % CellsOnEdge % array(1,iEdge)) & - angle_2d(i) = angle_2d(i) - pii - -! xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell) -! yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell) - - xp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * cos(angle_2d(i)) - yp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * sin(angle_2d(i)) - - end do - - end if - - - ma = n-1 - mw = grid % nEdgesOnCell % array (iCell) - - bmatrix = 0. - amatrix = 0. - wmatrix = 0. - - if (polynomial_order == 2) then - na = 6 - ma = ma+1 - - amatrix(1,1) = 1. - wmatrix(1,1) = 1. - do i=2,ma - amatrix(i,1) = 1. - amatrix(i,2) = xp(i-1) - amatrix(i,3) = yp(i-1) - amatrix(i,4) = xp(i-1)**2 - amatrix(i,5) = xp(i-1) * yp(i-1) - amatrix(i,6) = yp(i-1)**2 - - wmatrix(i,i) = 1. - end do - - else if (polynomial_order == 3) then - na = 10 - ma = ma+1 - - amatrix(1,1) = 1. - wmatrix(1,1) = 1. - do i=2,ma - amatrix(i,1) = 1. - amatrix(i,2) = xp(i-1) - amatrix(i,3) = yp(i-1) - - amatrix(i,4) = xp(i-1)**2 - amatrix(i,5) = xp(i-1) * yp(i-1) - amatrix(i,6) = yp(i-1)**2 - - amatrix(i,7) = xp(i-1)**3 - amatrix(i,8) = yp(i-1) * (xp(i-1)**2) - amatrix(i,9) = xp(i-1) * (yp(i-1)**2) - amatrix(i,10) = yp(i-1)**3 - - wmatrix(i,i) = 1. - - end do - - else - na = 15 - ma = ma+1 - - amatrix(1,1) = 1. - wmatrix(1,1) = 1. - do i=2,ma - amatrix(i,1) = 1. - amatrix(i,2) = xp(i-1) - amatrix(i,3) = yp(i-1) - - amatrix(i,4) = xp(i-1)**2 - amatrix(i,5) = xp(i-1) * yp(i-1) - amatrix(i,6) = yp(i-1)**2 - - amatrix(i,7) = xp(i-1)**3 - amatrix(i,8) = yp(i-1) * (xp(i-1)**2) - amatrix(i,9) = xp(i-1) * (yp(i-1)**2) - amatrix(i,10) = yp(i-1)**3 - - amatrix(i,11) = xp(i-1)**4 - amatrix(i,12) = yp(i-1) * (xp(i-1)**3) - amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2) - amatrix(i,14) = xp(i-1) * (yp(i-1)**3) - amatrix(i,15) = yp(i-1)**4 - - wmatrix(i,i) = 1. - - end do - - do i=1,mw - wmatrix(i,i) = 1. - end do - - end if - - call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 ) - - do i=1,grid % nEdgesOnCell % array (iCell) - ip1 = i+1 - if (ip1 > n-1) ip1 = 1 - - iEdge = grid % EdgesOnCell % array (i,iCell) - 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, & - xv2, yv2, zv2, & - xec, yec, zec ) - - thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), & - xc(i+1), yc(i+1), zc(i+1), & - xec, yec, zec ) - thetae_tmp = thetae_tmp + thetat(i) - if (iCell == grid % cellsOnEdge % array(1,iEdge)) then - thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp - else - thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp - end if -! else -! -! xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2) -! ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2) - - end if - - end do - -! fill second derivative stencil for rk advection - - do i=1, grid % nEdgesOnCell % array (iCell) - iEdge = grid % EdgesOnCell % array (i,iCell) - - - if ( grid % on_a_sphere ) then - if (iCell == grid % cellsOnEdge % array(1,iEdge)) then - - cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell))) - sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell))) - costsint = cos2t*sin2t - cos2t = cos2t**2 - sin2t = sin2t**2 - - do j=1,n - deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) & - + 2.*costsint*bmatrix(5,j) & - + 2.*sin2t*bmatrix(6,j) - end do - else - - cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell))) - sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell))) - costsint = cos2t*sin2t - cos2t = cos2t**2 - sin2t = sin2t**2 - - do j=1,n - deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) & - + 2.*costsint*bmatrix(5,j) & - + 2.*sin2t*bmatrix(6,j) - end do - end if - - else - - cos2t = cos(angle_2d(i)) - sin2t = sin(angle_2d(i)) - costsint = cos2t*sin2t - cos2t = cos2t**2 - sin2t = sin2t**2 - -! do j=1,n -! -! deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) & -! + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) & -! + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j) -! end do - - if (iCell == grid % cellsOnEdge % array(1,iEdge)) then - do j=1,n - deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) & - + 2.*costsint*bmatrix(5,j) & - + 2.*sin2t*bmatrix(6,j) - end do - else - do j=1,n - deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) & - + 2.*costsint*bmatrix(5,j) & - + 2.*sin2t*bmatrix(6,j) - end do - end if - - end if - end do - - end do ! end of loop over cells - - if (debug) stop - -! write(0,*) ' check for deriv2 coefficients, iEdge 4 ' -! -! iEdge = 4 -! j = 1 -! iCell = grid % cellsOnEdge % array(1,iEdge) -! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,1,iEdge) -! do j=2,7 -! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,1,iEdge) -! end do -! -! j = 1 -! iCell = grid % cellsOnEdge % array(2,iEdge) -! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,2,iEdge) -! do j=2,7 -! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,2,iEdge) -! end do -! stop - - end subroutine atm_initialize_advection_rk - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! FUNCTION SPHERE_ANGLE - ! - ! Computes the angle between arcs AB and AC, given points A, B, and C - ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - real (kind=RKIND) function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz) - - implicit none - - real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz - - real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC - - real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB - real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC - - real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC - real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC - real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC - - real (kind=RKIND) :: s ! Semiperimeter of the triangle - real (kind=RKIND) :: sin_angle - - a = acos(max(min(bx*cx + by*cy + bz*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (3) - b = acos(max(min(ax*cx + ay*cy + az*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (2) - c = acos(max(min(ax*bx + ay*by + az*bz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (1) - - ABx = bx - ax - ABy = by - ay - ABz = bz - az - - ACx = cx - ax - ACy = cy - ay - ACz = cz - az - - Dx = (ABy * ACz) - (ABz * ACy) - Dy = -((ABx * ACz) - (ABz * ACx)) - Dz = (ABx * ACy) - (ABy * ACx) - - s = 0.5*(a + b + c) -! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28) - sin_angle = sqrt(min(1.0_RKIND,max(0.0_RKIND,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28) - - if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then - sphere_angle = 2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND)) - else - sphere_angle = -2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND)) - end if - - end function sphere_angle - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! FUNCTION PLANE_ANGLE - ! - ! Computes the angle between vectors AB and AC, given points A, B, and C, and - ! a vector (u,v,w) normal to the plane. - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - real (kind=RKIND) function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w) - - implicit none - - real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w - - real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB - real (kind=RKIND) :: mAB ! The magnitude of AB - real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC - real (kind=RKIND) :: mAC ! The magnitude of AC - - real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC - real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC - real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC - - real (kind=RKIND) :: cos_angle - - ABx = bx - ax - ABy = by - ay - ABz = bz - az - mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0) - - ACx = cx - ax - ACy = cy - ay - ACz = cz - az - mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0) - - - Dx = (ABy * ACz) - (ABz * ACy) - Dy = -((ABx * ACz) - (ABz * ACx)) - Dz = (ABx * ACy) - (ABy * ACx) - - cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC) - - if ((Dx*u + Dy*v + Dz*w) >= 0.0) then - plane_angle = acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND)) - else - plane_angle = -acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND)) - end if - - end function plane_angle - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! FUNCTION ARC_LENGTH - ! - ! Returns the length of the great circle arc from A=(ax, ay, az) to - ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the - ! same sphere centered at the origin. - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - real (kind=RKIND) function arc_length(ax, ay, az, bx, by, bz) - - implicit none - - real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz - - real (kind=RKIND) :: r, c - real (kind=RKIND) :: cx, cy, cz - - cx = bx - ax - cy = by - ay - cz = bz - az - -! r = ax*ax + ay*ay + az*az -! c = cx*cx + cy*cy + cz*cz -! -! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r)) - - r = sqrt(ax*ax + ay*ay + az*az) - c = sqrt(cx*cx + cy*cy + cz*cz) -! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r)) - arc_length = r * 2.0 * asin(c/(2.0*r)) - - end function arc_length - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! SUBROUTINE ARC_BISECT - ! - ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from - ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the - ! surface of a sphere centered at the origin. - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz) - - implicit none - - real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz - real (kind=RKIND), intent(out) :: cx, cy, cz - - real (kind=RKIND) :: r ! Radius of the sphere - real (kind=RKIND) :: d - - r = sqrt(ax*ax + ay*ay + az*az) - - cx = 0.5*(ax + bx) - cy = 0.5*(ay + by) - cz = 0.5*(az + bz) - - if (cx == 0. .and. cy == 0. .and. cz == 0.) then - write(0,*) 'Error: arc_bisect: A and B are diametrically opposite' - else - d = sqrt(cx*cx + cy*cy + cz*cz) - cx = r * cx / d - cy = r * cy / d - cz = r * cz / d - end if - - end subroutine arc_bisect - - - subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne) - - implicit none - - integer, intent(in) :: m,n,ne - real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in - real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out - - ! local storage - - real (kind=RKIND), dimension(m,n) :: a - real (kind=RKIND), dimension(n,m) :: b - real (kind=RKIND), dimension(m,m) :: w,wt,h - real (kind=RKIND), dimension(n,m) :: at, ath - real (kind=RKIND), dimension(n,n) :: ata, atha, atha_inv -! real (kind=RKIND), dimension(n,n) :: ata_inv - integer, dimension(n) :: indx - - if ( (ne grid % defc_a % array - defc_b => grid % defc_b % array - cellsOnEdge => grid % cellsOnEdge % array - edgesOnCell => grid % edgesOnCell % array - - defc_a(:,:) = 0. - defc_b(:,:) = 0. - - pii = 2.*asin(1.0) - - if (debug) write(0,*) ' beginning cell loop ' - - do iCell = 1, grid % nCells - - if (debug) write(0,*) ' cell loop ', iCell - - cell_list(1) = iCell - do i=2, grid % nEdgesOnCell % array(iCell)+1 - cell_list(i) = grid % CellsOnCell % array(i-1,iCell) - end do - n = grid % nEdgesOnCell % array(iCell) + 1 - -! check to see if we are reaching outside the halo - - if (debug) write(0,*) ' points ', n - - do_the_cell = .true. - do i=1,n - if (cell_list(i) > grid % nCells) do_the_cell = .false. - end do - - - if (.not. do_the_cell) cycle - - -! compute poynomial fit for this cell if all needed neighbors exist - if (grid % on_a_sphere) then - - 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)/grid%sphere_radius - yc(i) = grid % yVertex % array(iv)/grid%sphere_radius - zc(i) = grid % zVertex % array(iv)/grid%sphere_radius - end do - - ! - ! In case the current cell center lies at exactly z=1.0, the sphere_angle() routine - ! may generate an FPE since the triangle it is given will have a zero side length - ! adjacent to the vertex whose angle we are trying to find; in this case, simply - ! set the value of theta_abs directly - ! - if (zc(1) == 1.0) then - theta_abs(iCell) = pii/2. - else - theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), & - xc(2), yc(2), zc(2), & - 0.0_RKIND, 0.0_RKIND, 1.0_RKIND ) - end if - - -! angles from cell center to neighbor centers (thetav) - - do i=1,n-1 - - ip2 = i+2 - if (ip2 > n) ip2 = 2 - - thetav(i) = sphere_angle( xc(1), yc(1), zc(1), & - xc(i+1), yc(i+1), zc(i+1), & - xc(ip2), yc(ip2), zc(ip2) ) - - 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. - do i=1,n-1 - dl_sphere(i) = dl_sphere(i)/length_scale - end do - - thetat(1) = 0. ! this defines the x direction, cell center 1 -> -! thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line - do i=2,n-1 - thetat(i) = thetat(i-1) + thetav(i-1) - end do - - do i=1,n-1 - xp(i) = cos(thetat(i)) * dl_sphere(i) - yp(i) = sin(thetat(i)) * dl_sphere(i) - end do - - else ! On an x-y plane - - xp(1) = grid % xCell % array(iCell) - yp(1) = grid % yCell % array(iCell) - - - do i=2,n - iv = grid % verticesOnCell % array(i-1,iCell) - xp(i) = grid % xVertex % array(iv) - yp(i) = grid % yVertex % array(iv) - end do - - end if - -! thetat(1) = 0. - thetat(1) = theta_abs(iCell) - do i=2,n-1 - ip1 = i+1 - if (ip1 == n) ip1 = 1 - thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & - xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, & - xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, & - 0.0_RKIND, 0.0_RKIND, 1.0_RKIND) - thetat(i) = thetat(i) + thetat(i-1) - end do - - area_cell = 0. - area_cellt = 0. - do i=1,n-1 - ip1 = i+1 - if (ip1 == n) ip1 = 1 - dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) - area_cell = area_cell + 0.25*(xp(i)+xp(ip1))*(yp(ip1)-yp(i)) - 0.25*(yp(i)+yp(ip1))*(xp(ip1)-xp(i)) - area_cellt = area_cellt + (0.25*(xp(i)+xp(ip1))*cos(thetat(i)) + 0.25*(yp(i)+yp(ip1))*sin(thetat(i)))*dl - end do - if (debug) write(0,*) ' area_cell, area_cellt ',area_cell, area_cellt,area_cell-area_cellt - - do i=1,n-1 - ip1 = i+1 - if (ip1 == n) ip1 = 1 - dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) - sint2 = (sin(thetat(i)))**2 - cost2 = (cos(thetat(i)))**2 - sint_cost = sin(thetat(i))*cos(thetat(i)) - defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell - defc_b(i,iCell) = dl*2.*sint_cost/area_cell - if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then - defc_a(i,iCell) = - defc_a(i,iCell) - defc_b(i,iCell) = - defc_b(i,iCell) - end if - - end do - - end do - - if (debug) write(0,*) ' exiting def weight calc ' - - end subroutine atm_initialize_deformation_weights - -end module atm_advection diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 8288b35f61..93a5373787 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -9,7 +9,6 @@ module atm_time_integration use mpas_grid_types use mpas_kind_types - use mpas_configure use mpas_constants use mpas_dmpar use mpas_vector_reconstruction @@ -43,27 +42,36 @@ subroutine atm_timestep(domain, dt, timeStamp, itimestep) character(len=*), intent(in) :: timeStamp integer, intent(in) :: itimestep + type (block_type), pointer :: block type (MPAS_Time_type) :: currTime type (MPAS_TimeInterval_type) :: dtInterval - character (len=StrKIND) :: xtime + character (len=StrKIND), pointer :: xtime + character (len=StrKIND) :: xtime_new + type (mpas_pool_type), pointer :: state + character (len=StrKIND), pointer :: config_time_integration + + + call mpas_pool_get_config(domain % blocklist % configs, 'config_time_integration', config_time_integration) if (trim(config_time_integration) == 'SRK3') then call atm_srk3(domain, dt, itimestep) else write(0,*) 'Unknown time integration option '//trim(config_time_integration) write(0,*) 'Currently, only ''SRK3'' is supported.' - stop + call mpas_dmpar_abort(domain % dminfo) end if call mpas_set_time(currTime, dateTimeString=timeStamp) call mpas_set_timeInterval(dtInterval, dt=dt) currTime = currTime + dtInterval - call mpas_get_time(currTime, dateTimeString=xtime) + call mpas_get_time(currTime, dateTimeString=xtime_new) block => domain % blocklist do while (associated(block)) - block % state % time_levs(2) % state % xtime % scalar = xtime + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_array(state, 'xtime', xtime, 2) + xtime = xtime_new block => block % next end do @@ -90,6 +98,7 @@ subroutine atm_srk3(domain, dt, itimestep) real (kind=RKIND), intent(in) :: dt integer, intent(in) :: itimestep + integer :: iCell, k, iEdge type (block_type), pointer :: block @@ -106,6 +115,71 @@ subroutine atm_srk3(domain, dt, itimestep) real (kind=RKIND) :: scalar_min, scalar_max real (kind=RKIND) :: global_scalar_min, global_scalar_max + integer, pointer :: config_number_of_sub_steps + logical, pointer :: config_scalar_advection + logical, pointer :: config_positive_definite + logical, pointer :: config_monotonic + logical, pointer :: config_print_global_minmax_vel + logical, pointer :: config_print_global_minmax_sca + real (kind=RKIND), pointer :: config_dt + character (len=StrKIND), pointer :: config_microp_scheme + + integer, pointer :: num_scalars, index_qv, nCells, nCellsSolve, nEdges, nEdgesSolve, nVertLevels + + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: diag_physics + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: tend_physics + + type (field2DReal), pointer :: theta_m_field + type (field3DReal), pointer :: scalars_field + type (field2DReal), pointer :: pressure_p_field + type (field2DReal), pointer :: rtheta_p_field + type (field2DReal), pointer :: rtheta_pp_field + type (field2DReal), pointer :: tend_u_field + type (field2DReal), pointer :: u_field + type (field2DReal), pointer :: w_field + type (field2DReal), pointer :: rw_p_field + type (field2DReal), pointer :: ru_p_field + type (field2DReal), pointer :: rho_pp_field + type (field2DReal), pointer :: pv_edge_field + type (field2DReal), pointer :: rho_edge_field + + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ + real (kind=RKIND), dimension(:,:,:), pointer :: scalars, scalars_1, scalars_2 + + real (kind=RKIND), dimension(:,:), pointer :: rqvdynten + + + ! + ! Retrieve configuration options + ! + call mpas_pool_get_config(domain % blocklist % configs, 'config_number_of_sub_steps', config_number_of_sub_steps) + call mpas_pool_get_config(domain % blocklist % configs, 'config_scalar_advection', config_scalar_advection) + call mpas_pool_get_config(domain % blocklist % configs, 'config_positive_definite', config_positive_definite) + call mpas_pool_get_config(domain % blocklist % configs, 'config_monotonic', config_monotonic) + call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', config_dt) + call mpas_pool_get_config(domain % blocklist % configs, 'config_microp_scheme', config_microp_scheme) + call mpas_pool_get_config(domain % blocklist % configs, 'config_print_global_minmax_vel', config_print_global_minmax_vel) + call mpas_pool_get_config(domain % blocklist % configs, 'config_print_global_minmax_sca', config_print_global_minmax_sca) + + ! + ! Retrieve field structures + ! + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + + ! + ! Retrieve fields + ! + call mpas_pool_get_field(state, 'theta_m', theta_m_field, 1) + call mpas_pool_get_field(state, 'scalars', scalars_field, 1) + call mpas_pool_get_field(diag, 'pressure_p', pressure_p_field) + call mpas_pool_get_field(diag, 'rtheta_p', rtheta_p_field) + ! ! Initialize RK weights @@ -127,21 +201,23 @@ subroutine atm_srk3(domain, dt, itimestep) if(debug) write(0,*) ' copy step in rk solver ' ! theta_m - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(1) % state % theta_m) + call mpas_dmpar_exch_halo_field(theta_m_field) ! scalars - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(1) % state % scalars) + call mpas_dmpar_exch_halo_field(scalars_field) ! pressure_p - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % pressure_p) + call mpas_dmpar_exch_halo_field(pressure_p_field) ! rtheta_p - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rtheta_p) + call mpas_dmpar_exch_halo_field(rtheta_p_field) block => domain % blocklist do while (associated(block)) - call atm_rk_integration_setup( block % state % time_levs(2) % state, block % state % time_levs(1) % state, block % diag ) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call atm_rk_integration_setup(state, diag) block => block % next end do @@ -156,7 +232,10 @@ subroutine atm_srk3(domain, dt, itimestep) block => domain % blocklist do while (associated(block)) ! The coefficients are set for owned cells (cqw) and for all edges of owned cells, - call atm_compute_moist_coefficients( block % state % time_levs(2) % state, block % diag, block % mesh ) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call atm_compute_moist_coefficients( block % dimensions, state, diag, mesh ) !MGD could do away with dimensions arg block => block % next end do @@ -164,7 +243,15 @@ subroutine atm_srk3(domain, dt, itimestep) if (debug) write(0,*) ' compute_dyn_tend ' block => domain % blocklist do while (associated(block)) - call atm_compute_dyn_tend( block % tend, block % state % time_levs(2) % state, block % diag, block % mesh, rk_step, dt ) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call atm_compute_dyn_tend( tend, state, diag, mesh, block % configs, nVertLevels, rk_step, dt ) + block => block % next end do if (debug) write(0,*) ' finished compute_dyn_tend ' @@ -173,13 +260,18 @@ subroutine atm_srk3(domain, dt, itimestep) if (debug) write(0,*) ' add physics tendencies ' block => domain % blocklist do while (associated(block)) - call physics_addtend( block % mesh, & - block % state % time_levs(1) % state, & - block % diag, & - block % tend, & - block % tend_physics, & - block % state % time_levs(2) % state % rho_zz % array(:,:), & - block % diag % rho_edge % array(:,:), & + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) + call physics_addtend( block, & + mesh, & + state, & + diag, & + tend, & + tend_physics, & + block % configs, & rk_step ) block => block % next end do @@ -193,12 +285,22 @@ subroutine atm_srk3(domain, dt, itimestep) !*********************************** ! tend_u - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % u, (/ 1 /)) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tend) + call mpas_pool_get_field(tend, 'u', tend_u_field) + call mpas_dmpar_exch_halo_field(tend_u_field, (/ 1 /)) block => domain % blocklist - do while (associated(block)) - call atm_set_smlstep_pert_variables( block % tend, block % diag, block % mesh ) - call atm_compute_vert_imp_coefs( block % state % time_levs(2) % state, block % mesh, block % diag, rk_sub_timestep(rk_step) ) + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call atm_set_smlstep_pert_variables( tend, diag, mesh, block % configs ) + call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step) ) + block => block % next end do @@ -212,8 +314,16 @@ subroutine atm_srk3(domain, dt, itimestep) block => domain % blocklist do while (associated(block)) - call atm_advance_acoustic_step( block % state % time_levs(2) % state, block % diag, block % tend, & - block % mesh, rk_sub_timestep(rk_step) ) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call atm_advance_acoustic_step( state, diag, tend, mesh, block % configs, nCells, nVertLevels, rk_sub_timestep(rk_step) ) + block => block % next end do @@ -222,32 +332,45 @@ subroutine atm_srk3(domain, dt, itimestep) ! rtheta_pp ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rtheta_pp, (/ 1 /)) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) + call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 1 /)) end do ! end of acoustic steps loop !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /)) - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rw_p) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_field(diag, 'rw_p', rw_p_field) + call mpas_dmpar_exch_halo_field(rw_p_field) !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % ru_p, (/ 2 /)) - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % ru_p) + call mpas_pool_get_field(diag, 'ru_p', ru_p_field) + call mpas_dmpar_exch_halo_field(ru_p_field) - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rho_pp) + call mpas_pool_get_field(diag, 'rho_pp', rho_pp_field) + call mpas_dmpar_exch_halo_field(rho_pp_field) ! the second layer of halo cells must be exchanged before calling atm_recover_large_step_variables - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rtheta_pp, (/ 2 /)) + call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) + call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 2 /)) block => domain % blocklist do while (associated(block)) - call atm_recover_large_step_variables( block % state % time_levs(2) % state, & - block % diag, block % tend, block % mesh, & - rk_timestep(rk_step), number_sub_steps(rk_step), rk_step ) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + + call atm_recover_large_step_variables( state, diag, tend, mesh, block % configs, rk_timestep(rk_step), number_sub_steps(rk_step), rk_step ) + block => block % next end do ! u !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % state % time_levs(2) % state % u, (/ 3 /)) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % u) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_field(state, 'u', u_field, 2) + call mpas_dmpar_exch_halo_field(u_field) ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). ! PD or monotonicity constraints applied only on the final Runge-Kutta substep. @@ -256,22 +379,26 @@ subroutine atm_srk3(domain, dt, itimestep) block => domain % blocklist do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + ! ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses ! the functionality of the advance_scalars routine; however, it is noticeably slower, ! so we use the advance_scalars routine for the first two RK substeps. ! if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars( block % tend, & - block % state % time_levs(1) % state, block % state % time_levs(2) % state, & - block % diag, & - block % mesh, rk_timestep(rk_step) ) + call atm_advance_scalars( tend, state, diag, mesh, block % configs, num_scalars, nVertLevels, rk_timestep(rk_step) ) else block % domain = domain - call atm_advance_scalars_mono( block % tend, & - block % state % time_levs(1) % state, block % state % time_levs(2) % state, & - block % diag, block % mesh, & - rk_timestep(rk_step)) + call atm_advance_scalars_mono( block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step) ) end if block => block % next end do @@ -284,24 +411,35 @@ subroutine atm_srk3(domain, dt, itimestep) block => domain % blocklist do while (associated(block)) - call atm_compute_solve_diagnostics( dt, block % state % time_levs(2) % state, block % diag, block % mesh ) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + + call atm_compute_solve_diagnostics( dt, state, 2, diag, mesh, block % configs ) + block => block % next end do if(debug) write(0,*) ' diagnostics complete ' ! w - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % w) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_field(state, 'w', w_field, 2) + call mpas_dmpar_exch_halo_field(w_field) ! pv_edge - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % pv_edge) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_field(diag, 'pv_edge', pv_edge_field) + call mpas_dmpar_exch_halo_field(pv_edge_field) ! rho_edge - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rho_edge) + call mpas_pool_get_field(diag, 'rho_edge', rho_edge_field) + call mpas_dmpar_exch_halo_field(rho_edge_field) ! scalars if (rk_step < 3) then - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % scalars) + call mpas_pool_get_field(state, 'scalars', scalars_field, 2) + call mpas_dmpar_exch_halo_field(scalars_field) end if end do ! rk_step loop @@ -309,13 +447,25 @@ subroutine atm_srk3(domain, dt, itimestep) !... compute full velocity vectors at cell centers: block => domain % blocklist do while (associated(block)) - call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, & - block % diag % uReconstructX % array, & - block % diag % uReconstructY % array, & - block % diag % uReconstructZ % array, & - block % diag % uReconstructZonal % array, & - block % diag % uReconstructMeridional % array & + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + + call mpas_reconstruct(mesh, u, & + uReconstructX, & + uReconstructY, & + uReconstructZ, & + uReconstructZonal, & + uReconstructMeridional & ) + block => block % next end do @@ -326,132 +476,212 @@ subroutine atm_srk3(domain, dt, itimestep) block => domain % blocklist do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_array(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_array(tend_physics, 'rqvdynten', rqvdynten) + !NOTE: The calculation of the tendency due to horizontal and vertical advection for the water vapor mixing ratio !requires that the subroutine atm_advance_scalars_mono was called on the third Runge Kutta step, so that a halo !update for the scalars at time_levs(1) is applied. A halo update for the scalars at time_levs(2) is done above. if (config_monotonic) then - block % tend_physics % rqvdynten % array(:,:) = & - ( block % state % time_levs(2) % state % scalars % array(block % state % time_levs(2) % state % index_qv,:,:) & - - block % state % time_levs(1) % state % scalars % array(block % state % time_levs(1) % state % index_qv,:,:) ) & - / config_dt + rqvdynten(:,:) = ( scalars_2(index_qv,:,:) - scalars_1(index_qv,:,:) ) / config_dt else - block % tend_physics % rqvdynten % array(:,:) = 0._RKIND + rqvdynten(:,:) = 0._RKIND end if !simply set to zero negative mixing ratios of different water species (for now): - where ( block % state % time_levs(2) % state % scalars % array(:,:,:) .lt. 0.) & - block % state % time_levs(2) % state % scalars % array(:,:,:) = 0. + where ( scalars_2(:,:,:) < 0.0) & + scalars_2(:,:,:) = 0.0 !call microphysics schemes: - if (config_microp_scheme .ne. 'off') & - call microphysics_driver ( block % state % time_levs(2) % state, block % diag, block % diag_physics, & - block % tend, block % mesh, itimestep ) + if (config_microp_scheme .ne. 'off') & + call microphysics_driver ( block % configs, mesh, state, 2, diag, diag_physics, tend, itimestep ) block => block % next end do #endif - 102 format(' global min, max scalar',i4,2(1x,e17.10)) - write(0,*) - block => domain % blocklist - do while (associated(block)) - scalar_min = 0. - scalar_max = 0. - do iCell = 1, block % mesh % nCellsSolve - do k = 1, block % mesh % nVertLevels - scalar_min = min(scalar_min, block % state % time_levs(2) % state % w % array(k,iCell)) - scalar_max = max(scalar_max, block % state % time_levs(2) % state % w % array(k,iCell)) - end do - end do - call mpas_dmpar_min_real(domain%dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain%dminfo, scalar_max, global_scalar_max) - write(0,*) 'global min, max w ',global_scalar_min, global_scalar_max + if (config_print_global_minmax_vel) then + write(0,*) - scalar_min = 0. - scalar_max = 0. - do iEdge = 1, block % mesh % nEdgesSolve - do k = 1, block % mesh % nVertLevels - scalar_min = min(scalar_min, block % state % time_levs(2) % state % u % array(k,iEdge)) - scalar_max = max(scalar_max, block % state % time_levs(2) % state % u % array(k,iEdge)) - end do - end do - call mpas_dmpar_min_real(domain%dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain%dminfo, scalar_max, global_scalar_max) - write(0,*) 'global min, max u ',global_scalar_min, global_scalar_max + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) + + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - do iScalar = 1, block % state % time_levs(2) % state % num_scalars - scalar_min = 0. - scalar_max = 0. - do iCell = 1, block % mesh % nCellsSolve - do k = 1, block % mesh % nVertLevels - scalar_min = min(scalar_min, block % state % time_levs(2) % state % scalars % array(iScalar,k,iCell)) - scalar_max = max(scalar_max, block % state % time_levs(2) % state % scalars % array(iScalar,k,iCell)) + scalar_min = 0.0 + scalar_max = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, w(k,iCell)) + scalar_max = max(scalar_max, w(k,iCell)) end do end do - call mpas_dmpar_min_real(domain%dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain%dminfo, scalar_max, global_scalar_max) - write(0,102) iScalar,global_scalar_min,global_scalar_max + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + write(0,*) 'global min, max w ', global_scalar_min, global_scalar_max + + scalar_min = 0.0 + scalar_max = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, u(k,iEdge)) + scalar_max = max(scalar_max, u(k,iEdge)) + end do + end do + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + write(0,*) 'global min, max u ', global_scalar_min, global_scalar_max + + block => block % next end do + end if - block => block % next - end do + if (config_print_global_minmax_sca) then + if (.not. config_print_global_minmax_vel) write(0,*) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) + + call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + + do iScalar = 1, num_scalars + scalar_min = 0.0 + scalar_max = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, scalars(iScalar,k,iCell)) + scalar_max = max(scalar_max, scalars(iScalar,k,iCell)) + end do + end do + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + write(0,'(a,i4,2(1x,e17.10))') ' global min, max scalar ', iScalar, global_scalar_min, global_scalar_max + end do + + block => block % next + end do + end if end subroutine atm_srk3 !--- - subroutine atm_rk_integration_setup( s_old, s_new, diag ) + subroutine atm_rk_integration_setup( state, diag ) implicit none - type (state_type) :: s_new, s_old - type (diag_type) :: diag - - diag % ru_save % array = diag % ru % array - diag % rw_save % array = diag % rw % array - diag % rtheta_p_save % array = diag % rtheta_p % array - diag % rho_p_save % array = diag % rho_p % array - - s_old % u % array = s_new % u % array - s_old % w % array = s_new % w % array - s_old % theta_m % array = s_new % theta_m % array - s_old % rho_zz % array = s_new % rho_zz % array - s_old % scalars % array = s_new % scalars % array + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: ru_save + real (kind=RKIND), dimension(:,:), pointer :: rw + real (kind=RKIND), dimension(:,:), pointer :: rw_save + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p_save + real (kind=RKIND), dimension(:,:), pointer :: rho_p + real (kind=RKIND), dimension(:,:), pointer :: rho_p_save + + real (kind=RKIND), dimension(:,:), pointer :: u_1, u_2 + real (kind=RKIND), dimension(:,:), pointer :: w_1, w_2 + real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 + real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2 + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_1, scalars_2 + + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'ru_save', ru_save) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'rw_save', rw_save) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array(diag, 'rho_p', rho_p) + call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) + + call mpas_pool_get_array(state, 'u', u_1, 1) + call mpas_pool_get_array(state, 'u', u_2, 2) + call mpas_pool_get_array(state, 'w', w_1, 1) + call mpas_pool_get_array(state, 'w', w_2, 2) + call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) + call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) + call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) + call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) + call mpas_pool_get_array(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + + ru_save(:,:) = ru(:,:) + rw_save(:,:) = rw(:,:) + rtheta_p_save(:,:) = rtheta_p(:,:) + rho_p_save(:,:) = rho_p(:,:) + + u_2(:,:) = u_1(:,:) + w_2(:,:) = w_1(:,:) + theta_m_2(:,:) = theta_m_1(:,:) + rho_zz_2(:,:) = rho_zz_1(:,:) + scalars_2(:,:,:) = scalars_1(:,:,:) end subroutine atm_rk_integration_setup !----- - subroutine atm_compute_moist_coefficients( state, diag, grid ) + subroutine atm_compute_moist_coefficients( dims, state, diag, mesh ) ! the moist coefficients cqu and cqw serve to transform the inverse dry density (1/rho_d) ! into the inverse full (moist) density (1/rho_m). implicit none - type (state_type) :: state - type (diag_type) :: diag - type (mesh_type) :: grid + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: mesh + integer :: iEdge, iCell, k, cell1, cell2, iq - integer :: nCells, nEdges, nVertLevels, nCellsSolve + integer, pointer :: nCells, nEdges, nVertLevels, nCellsSolve real (kind=RKIND) :: qtot integer, dimension(:,:), pointer :: cellsOnEdge + integer, pointer :: moist_start, moist_end + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:), pointer :: cqw + real (kind=RKIND), dimension(:,:), pointer :: cqu + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_dimension(dims, 'nEdges', nEdges) + call mpas_pool_get_dimension(dims, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'moist_start', moist_start) + call mpas_pool_get_dimension(state, 'moist_end', moist_end) - nCells = grid % nCells - nEdges = grid % nEdges - nVertLevels = grid % nVertLevels - nCellsSolve = grid % nCellsSolve + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_array(diag, 'cqw', cqw) + call mpas_pool_get_array(diag, 'cqu', cqu) - cellsOnEdge => grid % cellsOnEdge % array do iCell = 1, nCellsSolve do k = 2, nVertLevels qtot = 0. - do iq = state % moist_start, state % moist_end - qtot = qtot + 0.5 * (state % scalars % array (iq, k, iCell) + state % scalars % array (iq, k-1, iCell)) + do iq = moist_start, moist_end + qtot = qtot + 0.5 * (scalars(iq, k, iCell) + scalars(iq, k-1, iCell)) end do - diag % cqw % array(k,iCell) = 1./(1.+qtot) + cqw(k,iCell) = 1./(1.+qtot) end do end do @@ -461,10 +691,10 @@ subroutine atm_compute_moist_coefficients( state, diag, grid ) if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then do k = 1, nVertLevels qtot = 0. - do iq = state % moist_start, state % moist_end - qtot = qtot + 0.5 * ( state % scalars % array (iq, k, cell1) + state % scalars % array (iq, k, cell2) ) + do iq = moist_start, moist_end + qtot = qtot + 0.5 * ( scalars(iq, k, cell1) + scalars(iq, k, cell2) ) end do - diag % cqu % array(k,iEdge) = 1./( 1. + qtot) + cqu(k,iEdge) = 1./( 1. + qtot) end do end if end do @@ -473,64 +703,74 @@ end subroutine atm_compute_moist_coefficients !--- - subroutine atm_compute_vert_imp_coefs(s, grid, diag, dts) + subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, dts) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Compute coefficients for vertically implicit gravity-wave/acoustic computations ! - ! Input: s - current model state - ! grid - grid metadata + ! Input: state - current model state + ! mesh - grid metadata ! ! Output: diag - cofrz, cofwr, cofwz, coftz, cofwt, a, alpha and gamma !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - type (state_type), intent(in) :: s - type (mesh_type), intent(in) :: grid - type (diag_type), intent(inout) :: diag - real (kind=RKIND), intent(in) :: dts + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: nVertLevels ! for allocating stack variables + real (kind=RKIND), intent(in) :: dts integer :: iCell, k, iq - integer :: nCells, nVertLevels, nCellsSolve + integer, pointer :: nCells, nCellsSolve real (kind=RKIND), dimension(:,:), pointer :: zz, cqw, p, t, rb, rtb, pb, rt real (kind=RKIND), dimension(:,:), pointer :: cofwr, cofwz, coftz, cofwt, a_tri, alpha_tri, gamma_tri real (kind=RKIND), dimension(:), pointer :: cofrz, rdzw, fzm, fzp, rdzu + real (kind=RKIND), dimension(:,:,:), pointer :: scalars - real (kind=RKIND), dimension( grid % nVertLevels ) :: b_tri,c_tri - real (kind=RKIND) :: epssm, dtseps, c2, qtot, rcv + real (kind=RKIND), dimension( nVertLevels ) :: b_tri,c_tri + real (kind=RKIND), pointer :: epssm + real (kind=RKIND) :: dtseps, c2, qtot, rcv + + integer, pointer :: moist_start, moist_end ! set coefficients - nCells = grid % nCells - nCellsSolve = grid % nCellsSolve - nVertLevels = grid % nVertLevels - epssm = config_epssm - - rdzu => grid % rdzu % array - rdzw => grid % rdzw % array - fzm => grid % fzm % array - fzp => grid % fzp % array - zz => grid % zz % array - cqw => diag % cqw % array - - p => diag % exner % array - pb => diag % exner_base % array - rt => diag % rtheta_p % array - rtb => diag % rtheta_base % array - rb => diag % rho_base % array - - alpha_tri => diag % alpha_tri % array - gamma_tri => diag % gamma_tri % array - a_tri => diag % a_tri % array - cofwr => diag % cofwr % array - cofwz => diag % cofwz % array - coftz => diag % coftz % array - cofwt => diag % cofwt % array - cofrz => diag % cofrz % array - - t => s % theta_m % array + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_config(configs, 'config_epssm', epssm) + + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zz', zz) + + call mpas_pool_get_array(diag, 'cqw', cqw) + call mpas_pool_get_array(diag, 'exner', p) + call mpas_pool_get_array(diag, 'exner_base', pb) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(diag, 'rtheta_base', rtb) + call mpas_pool_get_array(diag, 'rho_base', rb) + + call mpas_pool_get_array(diag, 'alpha_tri', alpha_tri) + call mpas_pool_get_array(diag, 'gamma_tri', gamma_tri) + call mpas_pool_get_array(diag, 'a_tri', a_tri) + call mpas_pool_get_array(diag, 'cofwr', cofwr) + call mpas_pool_get_array(diag, 'cofwz', cofwz) + call mpas_pool_get_array(diag, 'coftz', coftz) + call mpas_pool_get_array(diag, 'cofwt', cofwt) + call mpas_pool_get_array(diag, 'cofrz', cofrz) + + call mpas_pool_get_array(state, 'theta_m', t, 2) + call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_dimension(state, 'moist_start', moist_start) + call mpas_pool_get_dimension(state, 'moist_end', moist_end) + dtseps = .5*dts*(1.+epssm) rcv = rgas/(cp-rgas) @@ -555,8 +795,8 @@ subroutine atm_compute_vert_imp_coefs(s, grid, diag, dts) do k=1,nVertLevels qtot = 0. - do iq = s % moist_start, s % moist_end - qtot = qtot + s % scalars % array (iq, k, iCell) + do iq = moist_start, moist_end + qtot = qtot + scalars(iq, k, iCell) end do cofwt(k,iCell) = .5*dtseps*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtot) & @@ -594,7 +834,7 @@ end subroutine atm_compute_vert_imp_coefs !------------------------ - subroutine atm_set_smlstep_pert_variables( tend, diag, grid ) + subroutine atm_set_smlstep_pert_variables( tend, diag, mesh, configs ) ! following Klemp et al MWR 2007, we use preturbation variables ! in the acoustic-step integration. This routine computes those @@ -604,49 +844,86 @@ subroutine atm_set_smlstep_pert_variables( tend, diag, grid ) implicit none - type (tend_type) :: tend - type (diag_type) :: diag - type (mesh_type) :: grid + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs integer :: iCell, iEdge, k, cell1, cell2 - real (kind=RKIND) :: coef_3rd_order - integer :: nCellsSolve, nCells, nVertLevels, nEdges + real (kind=RKIND), pointer :: coef_3rd_order + integer, pointer :: config_theta_adv_order + integer, pointer :: nCellsSolve, nCells, nVertLevels, nEdges integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:), pointer :: fzm, fzp, dvEdge, areaCell real (kind=RKIND) :: flux - - coef_3rd_order = config_coef_3rd_order - if (config_theta_adv_order /=3) coef_3rd_order = 0 - - nCellsSolve = grid % nCellsSolve - nCells = grid % nCells - nEdges = grid % nEdges - nVertLevels = grid % nVertLevels - - fzm => grid % fzm % array - fzp => grid % fzp % array - dvEdge => grid % dvEdge % array - areaCell => grid % areaCell % array - cellsOnEdge => grid % cellsOnEdge % array + real (kind=RKIND), dimension(:,:), pointer :: ruAvg, wwAvg + real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + real (kind=RKIND), dimension(:,:), pointer :: zz + real (kind=RKIND), dimension(:,:), pointer :: w_tend, u_tend + real (kind=RKIND), dimension(:,:), pointer :: rho_pp, rho_p_save, rho_p + real (kind=RKIND), dimension(:,:), pointer :: ru_p, ru, ru_save + real (kind=RKIND), dimension(:,:), pointer :: rtheta_pp, rtheta_p_save, rtheta_p, rtheta_pp_old + real (kind=RKIND), dimension(:,:), pointer :: rw_p, rw_save, rw + + + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_array(tend, 'w', w_tend) + call mpas_pool_get_array(tend, 'u', u_tend) + + call mpas_pool_get_array(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array(diag, 'wwAvg', wwAvg) + + call mpas_pool_get_array(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array(diag, 'rho_p', rho_p) + + call mpas_pool_get_array(diag, 'ru_p', ru_p) + call mpas_pool_get_array(diag, 'ru_save', ru_save) + call mpas_pool_get_array(diag, 'ru', ru) + + call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) + + call mpas_pool_get_array(diag, 'rw_p', rw_p) + call mpas_pool_get_array(diag, 'rw_save', rw_save) + call mpas_pool_get_array(diag, 'rw', rw) + + if (config_theta_adv_order /= 3) coef_3rd_order = 0.0 ! set the acoustic step perturbation variables by subtracting the RK timestep variables ! from their at the previous RK substep. - diag % rho_pp % array = diag % rho_p_save % array - diag % rho_p % array - diag % ru_p % array = diag % ru_save % array - diag % ru % array - diag % rtheta_pp % array = diag % rtheta_p_save % array - diag % rtheta_p % array - diag % rtheta_pp_old % array = diag % rtheta_pp % array - diag % rw_p % array = diag % rw_save % array - diag % rw % array + rho_pp = rho_p_save - rho_p + ru_p = ru_save - ru + rtheta_pp = rtheta_p_save - rtheta_p + rtheta_pp_old = rtheta_pp + rw_p = rw_save - rw ! we solve for omega instead of w (see Klemp et al MWR 2007), ! so here we change the w_p tendency to an omega_p tendency do iCell = 1, nCellsSolve - do k = 2, nVertLevels - tend % w % array(k,iCell) = ( fzm(k) * grid % zz % array(k ,iCell) + & - fzp(k) * grid % zz % array(k-1,iCell) ) & - * tend % w % array(k,iCell) - end do + do k = 2, nVertLevels + w_tend(k,iCell) = ( fzm(k) * zz(k,iCell) + fzp(k) * zz(k-1,iCell) ) * w_tend(k,iCell) + end do end do ! here we need to compute the omega tendency in a manner consistent with our diagnosis of omega. @@ -658,27 +935,27 @@ subroutine atm_set_smlstep_pert_variables( tend, diag, grid ) cell2 = cellsOnEdge(2,iEdge) do k = 2, nVertLevels - flux = fzm(k) * tend % u % array(k,iEdge) + fzp(k) * tend % u % array(k-1,iEdge) - tend % w % array(k,cell2) = tend % w % array(k,cell2) & - + (grid % zb % array(k,2,iEdge) + coef_3rd_order*sign(1.0_RKIND,tend % u % array(k,iEdge))*grid %zb3 % array(k,2,iEdge))*flux & - * (fzm(k) * grid % zz % array(k,cell2) + fzp(k) * grid % zz % array(k-1,cell2)) - tend % w % array(k,cell1) = tend % w % array(k,cell1) & - - (grid % zb % array(k,1,iEdge) + coef_3rd_order*sign(1.0_RKIND,tend % u % array(k,iEdge))*grid %zb3 % array(k,1,iEdge))*flux & - * (fzm(k) * grid % zz % array(k,cell1) + fzp(k) * grid % zz % array(k-1,cell1)) + flux = fzm(k) * u_tend(k,iEdge) + fzp(k) * u_tend(k-1,iEdge) + w_tend(k,cell2) = w_tend(k,cell2) & + + (zb(k,2,iEdge) + coef_3rd_order * sign(1.0_RKIND, u_tend(k,iEdge)) * zb3(k,2,iEdge)) * flux & + * (fzm(k) * zz(k,cell2) + fzp(k) * zz(k-1,cell2)) + w_tend(k,cell1) = w_tend(k,cell1) & + - (zb(k,1,iEdge) + coef_3rd_order * sign(1.0_RKIND, u_tend(k,iEdge)) * zb3(k,1,iEdge)) * flux & + * (fzm(k) * zz(k,cell1) + fzp(k) * zz(k-1,cell1)) end do end do ! ruAvg and wwAvg will store the mass fluxes averaged over the acoustic steps for the subsequent scalar transport. - diag % ruAvg % array = 0. - diag % wwAvg % array = 0. + ruAvg(:,:) = 0.0 + wwAvg(:,:) = 0.0 end subroutine atm_set_smlstep_pert_variables !------------------------------- - subroutine atm_advance_acoustic_step( s, diag, tend, grid, dts ) + subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, nVertLevels, dts ) ! This subroutine performs the entire acoustic step update, following Klemp et al MWR 2007, ! using forward-backward vertically implicit integration. @@ -688,10 +965,13 @@ subroutine atm_advance_acoustic_step( s, diag, tend, grid, dts ) implicit none - type (state_type) :: s - type (diag_type) :: diag - type (tend_type) :: tend - type (mesh_type) :: grid + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: nCells ! for allocating stack variables + integer, intent(in) :: nVertLevels ! for allocating stack variables real (kind=RKIND), intent(in) :: dts @@ -706,85 +986,87 @@ subroutine atm_advance_acoustic_step( s, diag, tend, grid, dts ) real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl, pzp, pzm integer, dimension(:,:), pointer :: cellsOnEdge - real (kind=RKIND) :: smdiv, c2, rcv - real (kind=RKIND), dimension( grid % nVertLevels ) :: du - real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: dpzx - real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells+1 ) :: ts, rs + real (kind=RKIND) :: c2, rcv + real (kind=RKIND), dimension( nVertLevels ) :: du + real (kind=RKIND), dimension( nVertLevels + 1 ) :: dpzx + real (kind=RKIND), dimension( nVertLevels, nCells+1 ) :: ts, rs integer :: cell1, cell2, iEdge, iCell, k - real (kind=RKIND) :: pgrad, flux, resm, epssm + real (kind=RKIND) :: pgrad, flux, resm + real (kind=RKIND), pointer :: epssm, smdiv - real (kind=RKIND) :: cf1, cf2, cf3, pr, pl + real (kind=RKIND), pointer :: cf1, cf2, cf3 + real (kind=RKIND) :: pr, pl integer :: kr, kl - integer :: nEdges, nCells, nCellsSolve, nVertLevels + integer, pointer :: nEdges, nCellsSolve logical, parameter :: debug = .false. logical, parameter :: debug1 = .false. - logical :: newpx + logical, pointer :: newpx !-- - cellsOnEdge => grid % cellsOnEdge % array - - rho_zz => s % rho_zz % array - theta_m => s % theta_m % array - w => s % w % array - - rtheta_pp => diag % rtheta_pp % array - rtheta_pp_old => diag % rtheta_pp_old % array - h_divergence => diag % h_divergence % array - ru_p => diag % ru_p % array - rw_p => diag % rw_p % array - exner => diag % exner % array - cqu => diag % cqu % array - ruAvg => diag % ruAvg % array - wwAvg => diag % wwAvg % array - rho_pp => diag % rho_pp % array - cofwt => diag % cofwt % array - coftz => diag % coftz % array - cofrz => diag % cofrz % array - cofwr => diag % cofwr % array - cofwz => diag % cofwz % array - a_tri => diag % a_tri % array - alpha_tri => diag % alpha_tri % array - gamma_tri => diag % gamma_tri % array - dss => grid % dss % array - - pzp => grid % pzp % array - pzm => grid % pzm % array - - tend_ru => tend % u % array - tend_rho => tend % rho_zz % array - tend_rt => tend % theta_m % array - tend_rw => tend % w % array - - zz => grid % zz % array - zx => grid % zx % array - zgrid => grid % zgrid % array - fzm => grid % fzm % array - fzp => grid % fzp % array - rdzw => grid % rdzw % array - dcEdge => grid % dcEdge % array - dvEdge => grid % dvEdge % array - AreaCell => grid % AreaCell % array - - nEdges = grid % nEdges - nCells = grid % nCells - nCellsSolve = grid % nCellsSolve - nVertLevels = grid % nVertLevels - - cf1 = grid % cf1 % scalar - cf2 = grid % cf2 % scalar - cf3 = grid % cf3 % scalar - - cpr => grid % cpr % array - cpl => grid % cpl % array - newpx = config_newpx + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(state, 'w', w, 2) + + call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) + call mpas_pool_get_array(diag, 'h_divergence', h_divergence) + call mpas_pool_get_array(diag, 'ru_p', ru_p) + call mpas_pool_get_array(diag, 'rw_p', rw_p) + call mpas_pool_get_array(diag, 'exner', exner) + call mpas_pool_get_array(diag, 'cqu', cqu) + call mpas_pool_get_array(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array(diag, 'cofwt', cofwt) + call mpas_pool_get_array(diag, 'coftz', coftz) + call mpas_pool_get_array(diag, 'cofrz', cofrz) + call mpas_pool_get_array(diag, 'cofwr', cofwr) + call mpas_pool_get_array(diag, 'cofwz', cofwz) + call mpas_pool_get_array(diag, 'a_tri', a_tri) + call mpas_pool_get_array(diag, 'alpha_tri', alpha_tri) + call mpas_pool_get_array(diag, 'gamma_tri', gamma_tri) + + call mpas_pool_get_array(mesh, 'dss', dss) + call mpas_pool_get_array(mesh, 'pzp', pzp) + call mpas_pool_get_array(mesh, 'pzm', pzm) + + call mpas_pool_get_array(tend, 'u', tend_ru) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array(tend, 'theta_m', tend_rt) + call mpas_pool_get_array(tend, 'w', tend_rw) + + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'zx', zx) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + + call mpas_pool_get_array(mesh, 'cpr', cpr) + call mpas_pool_get_array(mesh, 'cpl', cpl) + + call mpas_pool_get_config(configs, 'config_newpx', newpx) ! epssm is the offcentering coefficient for the vertically implicit integration. ! smdiv is the 3D divergence-damping coefficient. - epssm = config_epssm - smdiv = config_smdiv + call mpas_pool_get_config(configs, 'config_epssm', epssm) + call mpas_pool_get_config(configs, 'config_smdiv', smdiv) + rcv = rgas/(cp-rgas) c2 = cp*rcv @@ -983,7 +1265,7 @@ end subroutine atm_advance_acoustic_step !------------------------ - subroutine atm_recover_large_step_variables( s, diag, tend, grid, dt, ns, rk_step ) + subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, dt, ns, rk_step ) ! reconstitute state variables from acoustic-step perturbation variables ! after the acoustic steps. The perturbation variables were originally set in @@ -992,10 +1274,11 @@ subroutine atm_recover_large_step_variables( s, diag, tend, grid, dt, ns, rk_ste implicit none - type (state_type) :: s - type (diag_type) :: diag - type (tend_type) :: tend - type (mesh_type) :: grid + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: ns, rk_step real (kind=RKIND), intent(in) :: dt @@ -1005,72 +1288,83 @@ subroutine atm_recover_large_step_variables( s, diag, tend, grid, dt, ns, rk_ste rho_pp, rho_zz, rho_base, ruAvg, ru_save, ru_p, u, ru, & exner, exner_base, rtheta_base, pressure_p, & zz, theta_m, pressure_b, qvapor + real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:), pointer :: fzm, fzp, dvEdge, areaCell real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 integer, dimension(:,:), pointer :: cellsOnEdge integer :: iCell, iEdge, k, cell1, cell2 - integer :: nVertLevels, nCells, nCellsSolve, nEdges, nEdgesSolve - real (kind=RKIND) :: rcv, p0, cf1, cf2, cf3, flux, coef_3rd_order + integer, pointer :: nVertLevels, nCells, nCellsSolve, nEdges, nEdgesSolve + real (kind=RKIND) :: rcv, p0, flux + real (kind=RKIND), pointer :: cf1, cf2, cf3, coef_3rd_order + integer, pointer :: config_theta_adv_order + integer, pointer :: index_qv logical, parameter :: debug=.false. - wwAvg => diag % wwAvg % array - rw_save => diag % rw_save % array - rw => diag % rw % array - rw_p => diag % rw_p % array - w => s % w % array - - rtheta_p => diag % rtheta_p % array - rtheta_p_save => diag % rtheta_p_save % array - rtheta_pp => diag % rtheta_pp % array - rtheta_base => diag % rtheta_base % array - rt_diabatic_tend => tend % rt_diabatic_tend % array - theta_m => s % theta_m % array - qvapor => s % scalars % array(s%index_qv,:,:) - - rho_zz => s % rho_zz % array - rho_p => diag % rho_p % array - rho_p_save => diag % rho_p_save % array - rho_pp => diag % rho_pp % array - rho_base => diag % rho_base % array - - ruAvg => diag % ruAvg % array - ru_save => diag % ru_save % array - ru_p => diag % ru_p % array - ru => diag % ru % array - u => s % u % array - - exner => diag % exner % array - exner_base => diag % exner_base % array - - pressure_p => diag % pressure_p % array - pressure_b => diag % pressure_base % array - - zz => grid % zz % array - zb => grid % zb % array - zb3 => grid % zb3 % array - fzm => grid % fzm % array - fzp => grid % fzp % array - dvEdge => grid % dvEdge % array - areaCell => grid % areaCell % array - cellsOnEdge => grid % cellsOnEdge % array - - nVertLevels = grid % nVertLevels - nCells = grid % nCells - nCellsSolve = grid % nCellsSolve - nEdges = grid % nEdges - nEdgesSolve = grid % nEdgesSolve + call mpas_pool_get_array(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array(diag, 'rw_save', rw_save) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'rw_p', rw_p) + call mpas_pool_get_array(state, 'w', w, 2) + + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) + call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(state, 'scalars', scalars, 2) + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + + qvapor => scalars(index_qv,:,:) ! MGD does this actually work? + + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array(diag, 'rho_p', rho_p) + call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array(diag, 'rho_base', rho_base) + + call mpas_pool_get_array(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array(diag, 'ru_save', ru_save) + call mpas_pool_get_array(diag, 'ru_p', ru_p) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(state, 'u', u, 2) + + call mpas_pool_get_array(diag, 'exner', exner) + call mpas_pool_get_array(diag, 'exner_base', exner_base) + + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array(diag, 'pressure_base', pressure_b) + + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) rcv = rgas/(cp-rgas) p0 = 1.e+05 ! this should come from somewhere else... - cf1 = grid % cf1 % scalar - cf2 = grid % cf2 % scalar - cf3 = grid % cf3 % scalar - coef_3rd_order = config_coef_3rd_order - if (config_theta_adv_order /=3) coef_3rd_order = 0 + if (config_theta_adv_order /=3) coef_3rd_order = 0.0 ! compute new density everywhere so we can compute u from ru. ! we will also need it to compute theta_m below @@ -1161,7 +1455,7 @@ end subroutine atm_recover_large_step_variables !--------------------------------------------------------------------------------------- - subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) + subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, nVertLevels, dt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Integrate scalar equations - explicit transport plus other tendencies @@ -1172,7 +1466,7 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) ! ! input scalars in state are uncoupled (i.e. not mulitplied by density) ! - ! Output: updated uncoupled scalars (scalars in s_new). + ! Output: updated uncoupled scalars (scalars in state). ! Note: scalar tendencies are also modified by this routine. ! ! This routine DOES NOT apply any positive definite or monotonic renormalizations. @@ -1183,11 +1477,13 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) implicit none - type (tend_type), intent(in) :: tend - type (state_type), intent(in) :: s_old - type (state_type), intent(inout) :: s_new - type (diag_type), intent(in) :: diag - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(in) :: tend + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: num_scalars ! for allocating stack variables + integer, intent(in) :: nVertLevels ! for allocating stack variables real (kind=RKIND) :: dt integer :: i, iCell, iEdge, k, iScalar, cell1, cell2 @@ -1202,19 +1498,21 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) integer, dimension(:,:), pointer :: advCellsForEdge integer, dimension(:), pointer :: nAdvCellsForEdge real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd - real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels ) :: flux_arr + real (kind=RKIND), dimension( num_scalars, nVertLevels ) :: flux_arr - real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels + 1 ) :: wdtn - integer :: nCellsSolve, nEdges, nVertLevels + real (kind=RKIND), dimension( num_scalars, nVertLevels + 1 ) :: wdtn + integer, pointer :: nCellsSolve, nEdges real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 - real (kind=RKIND) :: coef_3rd_order + real (kind=RKIND), pointer :: coef_3rd_order - real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2 + real (kind=RKIND), pointer :: h_theta_eddy_visc2, v_theta_eddy_visc2 real (kind=RKIND) :: flux3, flux4 real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 + integer, pointer :: config_scalar_vadv_order + integer, parameter :: hadv_opt = 2 flux4(q_im2, q_im1, q_i, q_ip1, ua) = & @@ -1224,43 +1522,47 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) flux4(q_im2, q_im1, q_i, q_ip1, ua) + & coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 - coef_3rd_order = config_coef_3rd_order - - scalar_old => s_old % scalars % array - scalar_new => s_new % scalars % array - kdiff => diag % kdiff % array - deriv_two => grid % deriv_two % array - uhAvg => diag % ruAvg % array - dvEdge => grid % dvEdge % array - dcEdge => grid % dcEdge % array - cellsOnEdge => grid % cellsOnEdge % array - scalar_tend => tend % scalars % array - h_old => s_old % rho_zz % array - h_new => s_new % rho_zz % array - wwAvg => diag % wwAvg % array - areaCell => grid % areaCell % array - - fnm => grid % fzm % array - fnp => grid % fzp % array - rdnw => grid % rdzw % array - meshScalingDel2 => grid % meshScalingDel2 % array - meshScalingDel4 => grid % meshScalingDel4 % array - - nAdvCellsForEdge => grid % nAdvCellsForEdge % array - advCellsForEdge => grid % advCellsForEdge % array - adv_coefs => grid % adv_coefs % array - adv_coefs_3rd => grid % adv_coefs_3rd % array - - nCellsSolve = grid % nCellsSolve - nEdges = grid % nEdges - nVertLevels = grid % nVertLevels - - h_theta_eddy_visc2 = config_h_theta_eddy_visc2 - v_theta_eddy_visc2 = config_v_theta_eddy_visc2 - rho_edge => diag % rho_edge % array - rho_zz => s_new % rho_zz % array - qv_init => grid % qv_init % array - zgrid => grid % zgrid % array + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_config(configs, 'config_scalar_vadv_order', config_scalar_vadv_order) + + call mpas_pool_get_array(state, 'scalars', scalar_old, 1) + call mpas_pool_get_array(state, 'scalars', scalar_new, 2) + call mpas_pool_get_array(state, 'rho_zz', h_old, 1) + call mpas_pool_get_array(state, 'rho_zz', h_new, 2) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + + call mpas_pool_get_array(diag, 'kdiff', kdiff) + call mpas_pool_get_array(diag, 'ruAvg', uhAvg) + call mpas_pool_get_array(diag, 'wwAvg', wwAvg) + + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend) + + call mpas_pool_get_array(mesh, 'fzm', fnm) + call mpas_pool_get_array(mesh, 'fzp', fnp) + call mpas_pool_get_array(mesh, 'rdzw', rdnw) + call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) + + call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + + call mpas_pool_get_array(diag, 'rho_edge', rho_edge) + call mpas_pool_get_array(mesh, 'qv_init', qv_init) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + + call mpas_pool_get_config(configs, 'config_h_theta_eddy_visc2', h_theta_eddy_visc2) + call mpas_pool_get_config(configs, 'config_v_theta_eddy_visc2', v_theta_eddy_visc2) + #ifndef DO_PHYSICS scalar_tend = 0. ! testing purposes - we have no sources or sinks @@ -1284,7 +1586,7 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) iCell = advCellsForEdge(i,iEdge) do k=1,nVertLevels scalar_weight = adv_coefs(i,iEdge) + coef_3rd_order*sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(i,iEdge) - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars flux_arr(iScalar,k) = flux_arr(iScalar,k) + scalar_weight* scalar_new(iScalar,k,iCell) end do end do @@ -1294,7 +1596,7 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) ! note that the scalar tendency is modified. do k=1,nVertLevels - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) & - uhAvg(k,iEdge)*flux_arr(iScalar,k)/areaCell(cell1) scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) & @@ -1318,12 +1620,12 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) do iCell=1,nCellsSolve do k = 2, nVertLevels - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars 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,nVertLevels - do iScalar=1,s_old % num_scalars + 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) end do @@ -1335,24 +1637,24 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) do iCell=1,nCellsSolve k = 2 - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) end do do k=3,nVertLevels-1 - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars wdtn(iScalar,k) = flux3( scalar_new(iScalar,k-2,iCell),scalar_new(iScalar,k-1,iCell), & scalar_new(iScalar,k ,iCell),scalar_new(iScalar,k+1,iCell), & wwAvg(k,iCell), coef_3rd_order ) end do end do k = nVertLevels - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) end do do k=1,nVertLevels - do iScalar=1,s_old % num_scalars + 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) end do @@ -1365,22 +1667,22 @@ subroutine atm_advance_scalars( tend, s_old, s_new, diag, grid, dt) do iCell=1,nCellsSolve k = 2 - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) end do do k=3,nVertLevels-1 - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars wdtn(iScalar,k) = flux4( scalar_new(iScalar,k-2,iCell),scalar_new(iScalar,k-1,iCell), & scalar_new(iScalar,k ,iCell),scalar_new(iScalar,k+1,iCell), wwAvg(k,iCell) ) end do end do k = nVertLevels - do iScalar=1,s_old % num_scalars + do iScalar=1,num_scalars wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) end do do k=1,nVertLevels - do iScalar=1,s_old % num_scalars + 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) end do @@ -1398,7 +1700,7 @@ end subroutine atm_advance_scalars !--------------------------- - subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) + subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCells, nEdges, nVertLevels, dt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Integrate scalar equations - transport plus other tendencies @@ -1422,14 +1724,17 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) implicit none - type (tend_type),intent(in) :: tend - type (state_type),intent(inout) :: s_old - type (state_type),intent(inout) :: s_new - type (diag_type),intent(in) :: diag - type (mesh_type),intent(in) :: grid - real (kind=RKIND),intent(in) :: dt + type (block_type), intent(inout), target :: block + type (mpas_pool_type), intent(in) :: tend + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: nCells ! for allocating stack variables + integer, intent(in) :: nEdges ! for allocating stack variables + integer, intent(in) :: nVertLevels ! for allocating stack variables + real (kind=RKIND), intent(in) :: dt - type (block_type), pointer :: block integer :: i, iCell, iEdge, k, iScalar, cell1, cell2 real (kind=RKIND) :: flux, scalar_weight @@ -1437,31 +1742,34 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg, rho_edge, rho_zz, zgrid, kdiff real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell, qv_init - integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell integer, dimension(:,:), pointer :: advCellsForEdge integer, dimension(:), pointer :: nAdvCellsForEdge real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_old, scalars_new + type (field3DReal), pointer :: scalars_old_field type (field3DReal), pointer :: tempField type (field3DReal), target :: tempFieldTarget - real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: scalar_old, scalar_new - real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: s_max, s_min - real (kind=RKIND), dimension( 2, grid % nVertLevels, grid % nCells ), target :: scale_arr + real (kind=RKIND), dimension( nVertLevels, nCells ) :: scalar_old, scalar_new + real (kind=RKIND), dimension( nVertLevels, nCells ) :: s_max, s_min + real (kind=RKIND), dimension( 2, nVertLevels, nCells ), target :: scale_arr integer, parameter :: SCALE_IN = 1, SCALE_OUT = 2 - real (kind=RKIND), dimension( grid % nVertLevels, grid % nEdges ) :: flux_arr - real (kind=RKIND), dimension( grid % nVertLevels + 1, grid % nCells ) :: wdtn + real (kind=RKIND), dimension( nVertLevels, nEdges ) :: flux_arr + real (kind=RKIND), dimension( nVertLevels + 1, nCells ) :: wdtn - integer :: nCells, nCellsSolve, nEdges, nVertLevels, num_scalars, icellmax, kmax + integer, pointer :: nCellsSolve, num_scalars + integer :: icellmax, kmax real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 integer, dimension(:), pointer :: nEdgesOnCell - real (kind=RKIND) :: coef_3rd_order + real (kind=RKIND), pointer :: coef_3rd_order - real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2 + real (kind=RKIND), pointer :: h_theta_eddy_visc2, v_theta_eddy_visc2 real (kind=RKIND) :: flux3, flux4, flux_upwind real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3, scmin,scmax @@ -1478,45 +1786,46 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) flux4(q_im2, q_im1, q_i, q_ip1, ua) + & coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 - block => grid % block - - coef_3rd_order = config_coef_3rd_order - - kdiff => diag % kdiff % array - deriv_two => grid % deriv_two % array - uhAvg => diag % ruAvg % array - dvEdge => grid % dvEdge % array - dcEdge => grid % dcEdge % array - cellsOnEdge => grid % cellsOnEdge % array - scalar_tend => tend % scalars % array - h_old => s_old % rho_zz % array - h_new => s_new % rho_zz % array - wwAvg => diag % wwAvg % array - areaCell => grid % areaCell % array - - fnm => grid % fzm % array - fnp => grid % fzp % array - rdnw => grid % rdzw % array - meshScalingDel2 => grid % meshScalingDel2 % array - meshScalingDel4 => grid % meshScalingDel4 % array - - nEdgesOnCell => grid % nEdgesOnCell % array - nAdvCellsForEdge => grid % nAdvCellsForEdge % array - advCellsForEdge => grid % advCellsForEdge % array - adv_coefs => grid % adv_coefs % array - adv_coefs_3rd => grid % adv_coefs_3rd % array - - nCells = grid % nCells - nCellsSolve = grid % nCellsSolve - nEdges = grid % nEdges - nVertLevels = grid % nVertLevels - - h_theta_eddy_visc2 = config_h_theta_eddy_visc2 - v_theta_eddy_visc2 = config_v_theta_eddy_visc2 - rho_edge => diag % rho_edge % array - rho_zz => s_new % rho_zz % array - qv_init => grid % qv_init % array - zgrid => grid % zgrid % array + + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_config(configs, 'config_h_theta_eddy_visc2', h_theta_eddy_visc2) + call mpas_pool_get_config(configs, 'config_v_theta_eddy_visc2', v_theta_eddy_visc2) + + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + + call mpas_pool_get_array(diag, 'kdiff', kdiff) + call mpas_pool_get_array(diag, 'ruAvg', uhAvg) + call mpas_pool_get_array(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array(diag, 'rho_edge', rho_edge) + + call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend) + + call mpas_pool_get_array(state, 'rho_zz', h_old, 1) + call mpas_pool_get_array(state, 'rho_zz', h_new, 2) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array(state, 'scalars', scalars_old, 1) + call mpas_pool_get_array(state, 'scalars', scalars_new, 2) + call mpas_pool_get_field(state, 'scalars', scalars_old_field, 1) + + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'fzm', fnm) + call mpas_pool_get_array(mesh, 'fzp', fnp) + call mpas_pool_get_array(mesh, 'rdzw', rdnw) + call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + call mpas_pool_get_array(mesh, 'qv_init', qv_init) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) #ifndef DO_PHYSICS scalar_tend = 0. ! testing purposes - we have no sources or sinks @@ -1529,8 +1838,8 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) do iCell = 1, nCellsSolve do k = 1, nVertLevels - do iScalar = 1,s_old%num_scalars - s_old % scalars % array(iScalar,k,iCell) = s_old % scalars % array(iScalar,k,iCell)+dt*scalar_tend(iScalar,k,iCell) / h_old(k,iCell) + do iScalar = 1,num_scalars + scalars_old(iScalar,k,iCell) = scalars_old(iScalar,k,iCell)+dt*scalar_tend(iScalar,k,iCell) / h_old(k,iCell) scalar_tend(iScalar,k,iCell) = 0. end do end do @@ -1538,7 +1847,7 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) ! halo exchange - call mpas_dmpar_exch_halo_field(s_old % scalars) + call mpas_dmpar_exch_halo_field(scalars_old_field) ! ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old @@ -1546,15 +1855,13 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) ! do one scalar at a time - num_scalars = 1 - - do iScalar = 1, s_old % num_scalars - write(0,*) ' mono transport for scalar ',iScalar + do iScalar = 1, num_scalars +! write(0,*) ' mono transport for scalar ',iScalar do iCell = 1, nCells do k = 1, nVertLevels - scalar_old(k,iCell) = s_old % scalars % array(iScalar,k,iCell) - scalar_new(k,iCell) = s_new % scalars % array(iScalar,k,iCell) + scalar_old(k,iCell) = scalars_old(iScalar,k,iCell) + scalar_new(k,iCell) = scalars_new(iScalar,k,iCell) end do end do @@ -1590,7 +1897,7 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) ! zero flux at top and bottom wdtn(1,iCell) = 0. - wdtn(grid % nVertLevels+1,iCell) = 0. + wdtn(nVertLevels+1,iCell) = 0. k = 1 s_max(k,iCell) = max(scalar_old(1,iCell),scalar_old(2,iCell)) @@ -1617,9 +1924,9 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) ! pull s_min and s_max from the (horizontal) surrounding cells do i=1, nEdgesOnCell(iCell) - do k=1, grid % nVertLevels - s_max(k,iCell) = max(s_max(k,iCell),scalar_old(k, grid % CellsOnCell % array(i,iCell))) - s_min(k,iCell) = min(s_min(k,iCell),scalar_old(k, grid % CellsOnCell % array(i,iCell))) + do k=1, nVertLevels + s_max(k,iCell) = max(s_max(k,iCell),scalar_old(k, cellsOnCell(i,iCell))) + s_min(k,iCell) = min(s_min(k,iCell),scalar_old(k, cellsOnCell(i,iCell))) end do end do @@ -1682,7 +1989,7 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) cell2 = cellsOnEdge(2,iEdge) if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then ! only for owned cells do k=1, nVertLevels - flux_upwind = grid % dvEdge % array(iEdge) * dt * & + flux_upwind = dvEdge(iEdge) * dt * & (max(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell2)) flux_arr(k,iEdge) = dt*flux_arr(k,iEdge) - flux_upwind scalar_new(k,cell1) = scalar_new(k,cell1) - flux_upwind / areaCell(cell1) @@ -1739,8 +2046,8 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) tempField % block => block tempField % dimSizes(1) = 2 - tempField % dimSizes(2) = grid % nVertLevels - tempField % dimSizes(3) = grid % nCells + tempField % dimSizes(2) = nVertLevels + tempField % dimSizes(3) = nCells tempField % sendList => block % parinfo % cellsToSend tempField % recvList => block % parinfo % cellsToRecv tempField % copyList => block % parinfo % cellsToCopy @@ -1823,7 +2130,7 @@ subroutine atm_advance_scalars_mono(tend, s_old, s_new, diag, grid, dt) do iCell = 1, nCells do k=1, nVertLevels - s_new % scalars % array(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell)) + scalars_new(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell)) end do end do @@ -1833,12 +2140,12 @@ end subroutine atm_advance_scalars_mono !---- - subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) + subroutine atm_compute_dyn_tend(tend, state, diag, mesh, configs, nVertLevels, rk_step, dt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Compute height and normal wind tendencies, as well as diagnostic variables ! - ! Input: s - current model state - ! grid - grid metadata + ! Input: state - current model state + ! mesh - grid metadata ! diag - some grid diagnostics ! ! Output: tend - tendencies: tend_u, tend_w, tend_theta and tend_rho @@ -1849,10 +2156,12 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) implicit none - type (tend_type), intent(inout) :: tend - type (state_type), intent(in) :: s - type (diag_type), intent(in) :: diag - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: nVertLevels ! for allocating stack variables integer, intent(in) :: rk_step real (kind=RKIND), intent(in) :: dt @@ -1862,24 +2171,29 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, iq real (kind=RKIND) :: flux, workpv - integer :: nCells, nEdges, nVertices, nVertLevels, nCellsSolve, nEdgesSolve - real (kind=RKIND) :: h_mom_eddy_visc2, v_mom_eddy_visc2, h_mom_eddy_visc4 - real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, h_theta_eddy_visc4 + integer, pointer :: nCells, nEdges, nVertices, nCellsSolve, nEdgesSolve + integer, pointer :: moist_start, moist_end + real (kind=RKIND), pointer :: h_mom_eddy_visc2, v_mom_eddy_visc2 + real (kind=RKIND), pointer :: h_theta_eddy_visc2, v_theta_eddy_visc2 + real (kind=RKIND) :: h_mom_eddy_visc4 + real (kind=RKIND) :: h_theta_eddy_visc4 real (kind=RKIND) :: u_diffusion real (kind=RKIND), dimension(:), pointer :: fEdge, dvEdge, dcEdge, areaCell, areaTriangle, meshScalingDel2, meshScalingDel4 real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & circulation, divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zx, cqu, & h_divergence, kdiff + real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:,:), pointer :: tend_u_euler, tend_w_euler, tend_theta_euler real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two - integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge + integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge + real (kind=RKIND), dimension(:), pointer :: latCell, latEdge, angleEdge, u_init - real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx - real (kind=RKIND), dimension( grid % nVertLevels ) :: u_mix, ru_edge_w, q + real (kind=RKIND), dimension( nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx + real (kind=RKIND), dimension( nVertLevels ) :: u_mix, ru_edge_w, q real (kind=RKIND) :: theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2 @@ -1898,23 +2212,37 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) real (kind=RKIND), allocatable, dimension(:,:) :: delsq_theta, delsq_divergence real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity - real (kind=RKIND) :: cf1, cf2, cf3, pr, pl + real (kind=RKIND), pointer :: cf1, cf2, cf3 + real (kind=RKIND) :: pr, pl real (kind=RKIND) :: prandtl_inv logical, parameter :: debug = .false. logical, parameter :: curvature = .true. - real (kind=RKIND) :: r_earth + real (kind=RKIND), pointer :: 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), dimension( grid % nVertLevels ) :: d_diag, d_off_diag, flux_arr + real (kind=RKIND), dimension( nVertLevels ) :: d_diag, d_off_diag, flux_arr real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b - logical :: delsq_horiz_mixing, newpx - - - real (kind=RKIND) :: coef_3rd_order + logical :: delsq_horiz_mixing + + real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy + + real (kind=RKIND), pointer :: coef_3rd_order + logical, pointer :: newpx + logical, pointer :: config_mix_full + integer, pointer :: config_theta_vadv_order + character (len=StrKIND), pointer :: config_horiz_mixing + integer, pointer :: config_theta_adv_order + integer, pointer :: config_w_vadv_order + integer, pointer :: config_w_adv_order + real (kind=RKIND), pointer :: config_del4u_div_factor + real (kind=RKIND), pointer :: config_h_theta_eddy_visc4 + real (kind=RKIND), pointer :: config_h_mom_eddy_visc4 + real (kind=RKIND), pointer :: config_visc4_2dsmag + real (kind=RKIND), pointer :: config_len_disp real (kind=RKIND) :: flux3, flux4 real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 @@ -1928,106 +2256,123 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) !----------- - r_earth = grid % sphere_radius - ur_cell => diag % uReconstructZonal % array - vr_cell => diag % uReconstructMeridional % array - - coef_3rd_order = config_coef_3rd_order - - rho_zz => s % rho_zz % array - rho_edge => diag % rho_edge % array - rb => diag % rho_base % array - rr => diag % rho_p % array - u => s % u % array - v => diag % v % array - kdiff => diag % kdiff % array - ru => diag % ru % array - w => s % w % array - rw => diag % rw % array - theta_m => s % theta_m % array - circulation => diag % circulation % array - divergence => diag % divergence % array - vorticity => diag % vorticity % array - ke => diag % ke % array - pv_edge => diag % pv_edge % array - pp => diag % pressure_p % array - pressure_b => diag % pressure_base % array - h_divergence => diag % h_divergence % array - - pzp => grid % pzp % array - pzm => grid % pzm % array - - - weightsOnEdge => grid % weightsOnEdge % array - cellsOnEdge => grid % cellsOnEdge % array - verticesOnEdge => grid % verticesOnEdge % array - nEdgesOnEdge => grid % nEdgesOnEdge % array - edgesOnEdge => grid % edgesOnEdge % array - edgesOnCell => grid % edgesOnCell % array - dcEdge => grid % dcEdge % array - dvEdge => grid % dvEdge % array - areaCell => grid % areaCell % array - areaTriangle => grid % areaTriangle % array - fEdge => grid % fEdge % array - deriv_two => grid % deriv_two % array - zz => grid % zz % array - zx => grid % zx % array - - defc_a => grid % defc_a % array - defc_b => grid % defc_b % array - - meshScalingDel2 => grid % meshScalingDel2 % array - meshScalingDel4 => grid % meshScalingDel4 % array - - - tend_u => tend % u % array - tend_theta => tend % theta_m % array - tend_w => tend % w % array - tend_rho => tend % rho_zz % array - rt_diabatic_tend => tend % rt_diabatic_tend % array - - tend_u_euler => tend % u_euler % array - tend_theta_euler => tend % theta_euler % array - tend_w_euler => tend % w_euler % array - - t_init => grid % t_init % array - qv_init => grid % qv_init % array - - rdzu => grid % rdzu % array - rdzw => grid % rdzw % array - fzm => grid % fzm % array - fzp => grid % fzp % array - zgrid => grid % zgrid % array - cqw => diag % cqw % array - cqu => diag % cqu % array - - cpr => grid % cpr % array - cpl => grid % cpl % array - newpx = config_newpx - - nCells = grid % nCells - nEdges = grid % nEdges - nVertLevels = grid % nVertLevels - nVertices = grid % nVertices - nCellsSolve = grid % nCellsSolve - nEdgesSolve = grid % nEdgesSolve - - h_mom_eddy_visc2 = config_h_mom_eddy_visc2 -! h_mom_eddy_visc4 = config_h_mom_eddy_visc4 - v_mom_eddy_visc2 = config_v_mom_eddy_visc2 - h_theta_eddy_visc2 = config_h_theta_eddy_visc2 -! h_theta_eddy_visc4 = config_h_theta_eddy_visc4 - v_theta_eddy_visc2 = config_v_theta_eddy_visc2 - - nEdgesOnCell => grid % nEdgesOnCell % array - nAdvCellsForEdge => grid % nAdvCellsForEdge % array - advCellsForEdge => grid % advCellsForEdge % array - adv_coefs => grid % adv_coefs % array - adv_coefs_3rd => grid % adv_coefs_3rd % array + call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) + call mpas_pool_get_config(configs, 'config_newpx', newpx) + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_config(configs, 'config_mix_full', config_mix_full) + call mpas_pool_get_config(configs, 'config_theta_vadv_order', config_theta_vadv_order) + call mpas_pool_get_config(configs, 'config_horiz_mixing', config_horiz_mixing) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + call mpas_pool_get_config(configs, 'config_w_vadv_order', config_w_vadv_order) + call mpas_pool_get_config(configs, 'config_w_adv_order', config_w_adv_order) + call mpas_pool_get_config(configs, 'config_del4u_div_factor', config_del4u_div_factor) + call mpas_pool_get_config(configs, 'config_h_theta_eddy_visc4', config_h_theta_eddy_visc4) + call mpas_pool_get_config(configs, 'config_h_mom_eddy_visc4', config_h_mom_eddy_visc4) + call mpas_pool_get_config(configs, 'config_visc4_2dsmag', config_visc4_2dsmag) + call mpas_pool_get_config(configs, 'config_len_disp', config_len_disp) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(state, 'scalars', scalars, 2) + + call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) + call mpas_pool_get_array(diag, 'uReconstructMeridional', vr_cell) + call mpas_pool_get_array(diag, 'rho_edge', rho_edge) + call mpas_pool_get_array(diag, 'rho_base', rb) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(diag, 'v', v) + call mpas_pool_get_array(diag, 'kdiff', kdiff) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'circulation', circulation) + call mpas_pool_get_array(diag, 'divergence', divergence) + call mpas_pool_get_array(diag, 'vorticity', vorticity) + call mpas_pool_get_array(diag, 'ke', ke) + call mpas_pool_get_array(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'pressure_base', pressure_b) + call mpas_pool_get_array(diag, 'h_divergence', h_divergence) + + call mpas_pool_get_array(mesh, 'pzp', pzp) + call mpas_pool_get_array(mesh, 'pzm', pzm) + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'zx', zx) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array(mesh, 'defc_a', defc_a) + call mpas_pool_get_array(mesh, 'defc_b', defc_b) + call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 't_init', t_init) + call mpas_pool_get_array(mesh, 'qv_init', qv_init) + + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'cpr', cpr) + call mpas_pool_get_array(mesh, 'cpl', cpl) + + call mpas_pool_get_array(tend, 'u', tend_u) + call mpas_pool_get_array(tend, 'theta_m', tend_theta) + call mpas_pool_get_array(tend, 'w', tend_w) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) + call mpas_pool_get_array(tend, 'u_euler', tend_u_euler) + call mpas_pool_get_array(tend, 'theta_euler', tend_theta_euler) + call mpas_pool_get_array(tend, 'w_euler', tend_w_euler) + call mpas_pool_get_array(tend, 'w_pgf', tend_w_pgf) + call mpas_pool_get_array(tend, 'w_buoy', tend_w_buoy) + + call mpas_pool_get_array(diag, 'cqw', cqw) + call mpas_pool_get_array(diag, 'cqu', cqu) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_dimension(state, 'moist_start', moist_start) + call mpas_pool_get_dimension(state, 'moist_end', moist_end) + + call mpas_pool_get_config(configs, 'config_h_mom_eddy_visc2', h_mom_eddy_visc2) + call mpas_pool_get_config(configs, 'config_v_mom_eddy_visc2', v_mom_eddy_visc2) + call mpas_pool_get_config(configs, 'config_h_theta_eddy_visc2', h_theta_eddy_visc2) + call mpas_pool_get_config(configs, 'config_v_theta_eddy_visc2', v_theta_eddy_visc2) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + prandtl_inv = 1.0_RKIND/prandtl - write(0,*) ' rk_step in compute_dyn_tend ',rk_step +! write(0,*) ' rk_step in compute_dyn_tend ',rk_step delsq_horiz_mixing = .false. @@ -2058,9 +2403,9 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 delsq_horiz_mixing = .true. - write(0,*) '... config_visc4_2dsmag = ', config_visc4_2dsmag - write(0,*) '... h_mom_eddy_visc4 = ', h_mom_eddy_visc4 - write(0,*) '... h_theta_eddy_visc4 = ', h_theta_eddy_visc4 +! write(0,*) '... config_visc4_2dsmag = ', config_visc4_2dsmag +! write(0,*) '... h_mom_eddy_visc4 = ', h_mom_eddy_visc4 +! write(0,*) '... h_theta_eddy_visc4 = ', h_theta_eddy_visc4 else if ( config_horiz_mixing == "2d_fixed") then h_mom_eddy_visc4 = config_h_mom_eddy_visc4 h_theta_eddy_visc4 = config_h_theta_eddy_visc4 @@ -2070,10 +2415,6 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) tend_u(:,:) = 0.0 - cf1 = grid % cf1 % scalar - cf2 = grid % cf2 % scalar - cf3 = grid % cf3 % scalar - ! tendency for density. ! accumulate total water here for later use in w tendency calculation. @@ -2106,8 +2447,8 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) h_divergence(k,iCell) = divergence_ru(k,iCell) tend_rho(k,iCell) = -divergence_ru(k,iCell)-rdzw(k)*(rw(k+1,iCell)-rw(k,iCell)) - do iq = s % moist_start, s % moist_end - qtot(k,iCell) = qtot(k,iCell) + s % scalars % array (iq, k, iCell) + do iq = moist_start, moist_end + qtot(k,iCell) = qtot(k,iCell) + scalars(iq, k, iCell) end do end do @@ -2216,7 +2557,7 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) ! curvature terms for the sphere tend_u(k,iEdge) = tend_u(k,iEdge) & - - 2.*omega*cos(grid % angleEdge % array(iEdge))*cos(grid % latEdge % array(iEdge)) & + - 2.*omega*cos(angleEdge(iEdge))*cos(latEdge(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 @@ -2421,9 +2762,9 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) do k=1,nVertLevels #ifdef ROTATED_GRID - u_mix(k) = u(k,iEdge) - grid % u_init % array(k) * sin( grid % angleEdge % array(iEdge) ) + u_mix(k) = u(k,iEdge) - u_init(k) * sin( angleEdge(iEdge) ) #else - u_mix(k) = u(k,iEdge) - grid % u_init % array(k) * cos( grid % angleEdge % array(iEdge) ) + u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) #endif end do @@ -2461,6 +2802,10 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) !----------- rhs for w tend_w(:,:) = 0. + if(rk_step .eq. 1) then + tend_w_pgf(:,:) = 0. + tend_w_buoy(:,:) = 0. + endif ! ! horizontal advection for w @@ -2524,12 +2869,12 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) d2fdx2_cell1 = deriv_two(1,1,iEdge) * w(k,cell1) d2fdx2_cell2 = deriv_two(1,2,iEdge) * w(k,cell2) do i=1, nEdgesOnCell(cell1) - if ( grid % CellsOnCell % array (i,cell1) <= nCells) & - d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * w(k,grid % CellsOnCell % array (i,cell1)) + if ( cellsOnCell(i,cell1) <= nCells) & + d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * w(k,cellsOnCell(i,cell1)) end do do i=1, nEdgesOnCell(cell2) - if ( grid % CellsOnCell % array (i,cell2) <= nCells) & - d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * w(k,grid % CellsOnCell % array (i,cell2)) + if ( cellsOnCell(i,cell2) <= nCells) & + d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * w(k,cellsOnCell(i,cell2)) end do flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge)) * ( & @@ -2552,7 +2897,7 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) 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)) & + + 2.*omega*cos(latCell(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)) @@ -2712,6 +3057,16 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) rr(k,iCell)*(1.+qtot(k,iCell))) & +fzp(k)*(rb(k-1,iCell)*(qtot(k-1,iCell)) + & rr(k-1,iCell)*(1.+qtot(k-1,iCell))) )) + + if(rk_step == 1) then + tend_w_pgf(k,iCell) = cqw(k,iCell)*(rdzu(k)*(pp(k,iCell)-pp(k-1,iCell))) + tend_w_buoy(k,iCell) = cqw(k,iCell)*gravity* & + ( fzm(k)*(rb(k,iCell)*(qtot(k,iCell)) + & + rr(k,iCell)*(1.+qtot(k,iCell))) & + +fzp(k)*(rb(k-1,iCell)*(qtot(k-1,iCell)) + & + rr(k-1,iCell)*(1.+qtot(k-1,iCell))) ) + endif + end do end do @@ -2804,12 +3159,12 @@ subroutine atm_compute_dyn_tend(tend, s, diag, grid, rk_step, dt) d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta_m(k,cell1) d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta_m(k,cell2) do i=1, nEdgesOnCell(cell1) - if ( grid % CellsOnCell % array (i,cell1) <= grid%nCells) & - d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta_m(k,grid % CellsOnCell % array (i,cell1)) + if ( cellsOnCell(i,cell1) <= nCells) & + d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta_m(k,cellsOnCell(i,cell1)) end do do i=1, nEdgesOnCell(cell2) - if ( grid % CellsOnCell % array (i,cell2) <= grid%nCells) & - d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta_m(k,grid % CellsOnCell % array (i,cell2)) + if ( cellsOnCell(i,cell2) <= nCells) & + d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta_m(k,cellsOnCell(i,cell2)) end do flux = dvEdge(iEdge) * ru(k,iEdge) * ( & @@ -3026,7 +3381,7 @@ end subroutine atm_compute_dyn_tend !------- - subroutine atm_compute_solve_diagnostics(dt, s, diag, grid) + subroutine atm_compute_solve_diagnostics(dt, state, time_lev, diag, mesh, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Compute diagnostic fields used in the tendency computations ! @@ -3038,15 +3393,17 @@ subroutine atm_compute_solve_diagnostics(dt, s, diag, grid) implicit none real (kind=RKIND), intent(in) :: dt - type (state_type), intent(inout) :: s - type (diag_type), intent(inout) :: diag - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(inout) :: state + integer, intent(in) :: time_lev ! which time level of state to use + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: configs integer :: iEdge, iCell, iVertex, k, cell1, cell2, eoe, i real (kind=RKIND) :: h_vertex, r - integer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree + integer, pointer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree real (kind=RKIND), dimension(:), pointer :: fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, & circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, & @@ -3056,46 +3413,51 @@ subroutine atm_compute_solve_diagnostics(dt, s, diag, grid) logical, parameter :: hollingsworth=.true. real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex - real (kind=RKIND) :: ke_fact - - - h => s % rho_zz % array - u => s % u % array - v => diag % v % array - vh => diag % rv % array - h_edge => diag % rho_edge % array - circulation => diag % circulation % array - vorticity => diag % vorticity % array - divergence => diag % divergence % array - ke => diag % ke % array - pv_edge => diag % pv_edge % array - pv_vertex => diag % pv_vertex % array - pv_cell => diag % pv_cell % array - gradPVn => diag % gradPVn % array - gradPVt => diag % gradPVt % 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 - edgesOnCell => grid % edgesOnCell % 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 - fVertex => grid % fVertex % array - fEdge => grid % fEdge % array - - nCells = grid % nCells - nEdges = grid % nEdges - nVertices = grid % nVertices - nVertLevels = grid % nVertLevels - vertexDegree = grid % vertexDegree + real (kind=RKIND) :: ke_fact + real (kind=RKIND), pointer :: config_apvm_upwinding + + + call mpas_pool_get_config(configs, 'config_apvm_upwinding', config_apvm_upwinding) + + call mpas_pool_get_array(state, 'rho_zz', h, time_lev) + call mpas_pool_get_array(state, 'u', u, time_lev) + + call mpas_pool_get_array(diag, 'v', v) + call mpas_pool_get_array(diag, 'rv', vh) + call mpas_pool_get_array(diag, 'rho_edge', h_edge) + call mpas_pool_get_array(diag, 'circulation', circulation) + call mpas_pool_get_array(diag, 'vorticity', vorticity) + call mpas_pool_get_array(diag, 'divergence', divergence) + call mpas_pool_get_array(diag, 'ke', ke) + call mpas_pool_get_array(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) + call mpas_pool_get_array(diag, 'pv_cell', pv_cell) + call mpas_pool_get_array(diag, 'gradPVn', gradPVn) + call mpas_pool_get_array(diag, 'gradPVt', gradPVt) + + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) + ! ! Compute height on cell edges at velocity locations @@ -3315,36 +3677,87 @@ end subroutine atm_compute_solve_diagnostics !---------- - subroutine atm_init_coupled_diagnostics( state, diag, grid ) + subroutine atm_init_coupled_diagnostics( state, time_lev, diag, mesh, configs ) implicit none - type (state_type), intent(inout) :: state - type (diag_type), intent(inout) :: diag - type (mesh_type), intent(inout) :: grid - - integer :: k,iCell,iEdge,iCell1,iCell2, cell1, cell2 - real (kind=RKIND) :: coef_3rd_order - integer :: nCells, nEdges, nVertLevels + type (mpas_pool_type), intent(inout) :: state + integer, intent(in) :: time_lev ! which time level to use from state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs + + integer :: k, iCell, iEdge, iCell1, iCell2, cell1, cell2 + real (kind=RKIND), pointer :: coef_3rd_order + integer, pointer :: config_theta_adv_order + integer, pointer :: nCells, nEdges, nVertLevels + integer, pointer :: index_qv real (kind=RKIND) :: p0, rcv, flux integer, dimension(:,:), pointer :: cellsOnEdge + real (kind=RKIND), dimension(:,:), pointer :: theta_m + real (kind=RKIND), dimension(:,:), pointer :: theta + real (kind=RKIND), dimension(:,:), pointer :: rho_zz + real (kind=RKIND), dimension(:,:), pointer :: rho + real (kind=RKIND), dimension(:,:), pointer :: rho_p + real (kind=RKIND), dimension(:,:), pointer :: rho_base + real (kind=RKIND), dimension(:,:), pointer :: rtheta_base + real (kind=RKIND), dimension(:,:), pointer :: theta_base + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p + real (kind=RKIND), dimension(:,:), pointer :: zz + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rw + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: pressure_p + real (kind=RKIND), dimension(:,:), pointer :: exner + real (kind=RKIND), dimension(:,:), pointer :: exner_base + real (kind=RKIND), dimension(:), pointer :: fzm, fzp + real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 - nCells = grid % nCells - nEdges = grid % nEdges - nVertLevels = grid % nVertLevels - - cellsOnEdge => grid % cellsOnEdge % array - coef_3rd_order = config_coef_3rd_order - if(config_theta_adv_order /=3) coef_3rd_order = 0 + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + + call mpas_pool_get_array(state, 'theta_m', theta_m, time_lev) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, time_lev) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'rho_p', rho_p) + call mpas_pool_get_array(diag, 'rho_base', rho_base) + call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) + call mpas_pool_get_array(diag, 'theta_base', theta_base) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(state, 'scalars', scalars, time_lev) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(state, 'u', u, time_lev) + call mpas_pool_get_array(state, 'w', w, time_lev) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array(diag, 'exner', exner) + call mpas_pool_get_array(diag, 'exner_base', exner_base) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + + if (config_theta_adv_order /= 3) coef_3rd_order = 0.0 rcv = rgas / (cp-rgas) p0 = 1.e5 ! this should come from somewhere else... do iCell=1,nCells do k=1,nVertLevels - state % theta_m % array(k,iCell) = diag % theta % array(k,iCell) * (1._RKIND + rvord * state % scalars % array(state % index_qv,k,iCell)) - state % rho_zz % array(k,iCell) = diag % rho % array(k,iCell) / grid % zz % array(k,iCell) + theta_m(k,iCell) = theta(k,iCell) * (1._RKIND + rvord * scalars(index_qv,k,iCell)) + rho_zz(k,iCell) = rho(k,iCell) / zz(k,iCell) end do end do @@ -3352,7 +3765,7 @@ subroutine atm_init_coupled_diagnostics( state, diag, grid ) iCell1 = cellsOnEdge(1,iEdge) iCell2 = cellsOnEdge(2,iEdge) do k=1,nVertLevels - diag % ru % array(k,iEdge) = 0.5 * state % u % array(k,iEdge) * (state % rho_zz % array(k,iCell1) + state % rho_zz % array(k,iCell2)) + ru(k,iEdge) = 0.5 * u(k,iEdge) * (rho_zz(k,iCell1) + rho_zz(k,iCell2)) end do end do @@ -3360,12 +3773,12 @@ subroutine atm_init_coupled_diagnostics( state, diag, grid ) ! We are reversing the procedure we use in subroutine atm_recover_large_step_variables. ! first, the piece that depends on w. do iCell=1,nCells - diag % rw % array(1,iCell) = 0. - diag % rw % array(grid%nVertLevels+1,iCell) = 0. + rw(1,iCell) = 0.0 + rw(nVertLevels+1,iCell) = 0.0 do k=2,nVertLevels - diag % rw % array(k,iCell) = state % w % array(k,iCell) & - * (grid % fzp % array(k) * state % rho_zz % array(k-1,iCell) + grid % fzm % array(k) * state % rho_zz % array(k,iCell)) & - * (grid % fzp % array(k) * grid % zz % array(k-1,iCell) + grid % fzm % array(k) * grid % zz % array(k,iCell)) + rw(k,iCell) = w(k,iCell) & + * (fzp(k) * rho_zz(k-1,iCell) + fzm(k) * rho_zz(k,iCell)) & + * (fzp(k) * zz(k-1,iCell) + fzm(k) * zz(k,iCell)) end do end do @@ -3374,46 +3787,46 @@ subroutine atm_init_coupled_diagnostics( state, diag, grid ) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) do k = 2, nVertLevels - flux = (grid % fzm % array(k) * diag % ru % array(k,iEdge)+grid % fzp % array(k) * diag % ru % array(k-1,iEdge)) - diag % rw % array(k,cell2) = diag % rw % array(k,cell2) & - + (grid % zb % array(k,2,iEdge) + coef_3rd_order * sign(1.0_RKIND,flux) * grid % zb3 % array(k,2,iEdge))*flux & - * (grid % fzp % array(k) * grid % zz % array(k-1,cell2) + grid % fzm % array(k) * grid % zz % array(k,cell2)) - diag % rw % array(k,cell1) = diag % rw % array(k,cell1) & - - (grid % zb % array(k,1,iEdge) + coef_3rd_order * sign(1.0_RKIND,flux) * grid % zb3 % array(k,1,iEdge))*flux & - * (grid % fzp % array(k) * grid % zz % array(k-1,cell1) + grid % fzm % array(k) * grid % zz % array(k,cell1)) + flux = (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge)) + rw(k,cell2) = rw(k,cell2) & + + (zb(k,2,iEdge) + coef_3rd_order * sign(1.0_RKIND,flux) * zb3(k,2,iEdge))*flux & + * (fzp(k) * zz(k-1,cell2) + fzm(k) * zz(k,cell2)) + rw(k,cell1) = rw(k,cell1) & + - (zb(k,1,iEdge) + coef_3rd_order * sign(1.0_RKIND,flux) * zb3(k,1,iEdge))*flux & + * (fzp(k) * zz(k-1,cell1) + fzm(k) * zz(k,cell1)) end do end do do iCell = 1, nCells do k=1,nVertLevels - diag % rho_p % array(k,iCell) = state % rho_zz % array(k,iCell) - diag % rho_base % array(k,iCell) + rho_p(k,iCell) = rho_zz(k,iCell) - rho_base(k,iCell) end do end do do iCell = 1, nCells do k=1,nVertLevels - diag % rtheta_base % array(k,iCell) = diag % theta_base % array(k,iCell) * diag % rho_base % array(k,iCell) + rtheta_base(k,iCell) = theta_base(k,iCell) * rho_base(k,iCell) end do end do do iCell = 1, nCells do k=1,nVertLevels - diag % rtheta_p % array(k,iCell) = state % theta_m % array(k,iCell) * diag % rho_p % array(k,iCell) & - + diag % rho_base % array(k,iCell) * (state % theta_m % array(k,iCell) - diag % theta_base % array(k,iCell)) + rtheta_p(k,iCell) = theta_m(k,iCell) * rho_p(k,iCell) & + + rho_base(k,iCell) * (theta_m(k,iCell) - theta_base(k,iCell)) end do end do do iCell=1,nCells do k=1,nVertLevels - diag % exner % array(k,iCell) = (grid % zz % array(k,iCell) * (rgas/p0) * (diag % rtheta_p % array(k,iCell) + diag % rtheta_base % array(k,iCell)))**rcv + exner(k,iCell) = (zz(k,iCell) * (rgas/p0) * (rtheta_p(k,iCell) + rtheta_base(k,iCell)))**rcv end do end do do iCell=1,nCells do k=1,nVertLevels - diag % pressure_p % array(k,iCell) = grid % zz % array(k,iCell) * rgas & - * ( diag % exner % array(k,iCell) * diag % rtheta_p % array(k,iCell) & - + diag % rtheta_base % array(k,iCell) * (diag % exner % array(k,iCell) - diag % exner_base % array(k,iCell)) & + pressure_p(k,iCell) = zz(k,iCell) * rgas & + * ( exner(k,iCell) * rtheta_p(k,iCell) & + + rtheta_base(k,iCell) * (exner(k,iCell) - exner_base(k,iCell)) & ) end do end do diff --git a/src/core_atmosphere/mpas_atm_interp_diagnostics.F b/src/core_atmosphere/mpas_atm_interp_diagnostics.F index 044552d2f1..fc48e64f94 100644 --- a/src/core_atmosphere/mpas_atm_interp_diagnostics.F +++ b/src/core_atmosphere/mpas_atm_interp_diagnostics.F @@ -7,6 +7,7 @@ ! !================================================================================================== module mpas_atm_interp_diagnostics + use mpas_dmpar use mpas_kind_types use mpas_grid_types use mpas_constants @@ -18,67 +19,148 @@ module mpas_atm_interp_diagnostics contains !================================================================================================== - subroutine interp_diagnostics(mesh,state,diag,diag_physics) + subroutine interp_diagnostics(mesh, state, time_lev, diag, diag_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh - type(state_type),intent(in):: state + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: state + integer, intent(in) :: time_lev ! which time level to use from state !inout arguments: - type(diag_type),intent(inout):: diag - type(diag_physics_type),intent(inout):: diag_physics + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: diag_physics !local variables: - integer:: iCell,iVert,iVertD,k,kk - integer:: nCells,nVertLevels,nVertLevelsP1,nVertices,VertexDegree - integer,dimension(:,:),pointer:: cellsOnVertex + integer :: iCell,iVert,iVertD,k,kk + integer, pointer :: nCells, nVertLevels, nVertices, vertexDegree + integer :: nVertLevelsP1 + integer, pointer :: index_qv + integer, dimension(:,:), pointer :: cellsOnVertex - real(kind=RKIND),dimension(:),pointer:: areaTriangle - real(kind=RKIND),dimension(:,:),pointer:: kiteAreasOnVertex - - real(kind=RKIND),dimension(:,:),pointer:: exner,height - real(kind=RKIND),dimension(:,:),pointer:: pressure_b,pressure_p - real(kind=RKIND),dimension(:,:),pointer:: qvapor,relhum,theta_m,vorticity - real(kind=RKIND),dimension(:,:),pointer:: umeridional,uzonal,vvel + type (field2DReal), pointer:: pressure_p_field - real(kind=RKIND),dimension(:,:),allocatable:: pressure,pressureCp1,pressure2,pressure_v,temperature + real (kind=RKIND), dimension(:), pointer :: areaTriangle + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + + real (kind=RKIND), dimension(:,:), pointer :: exner, height + real (kind=RKIND), dimension(:,:), pointer :: pressure_b, pressure_p + real (kind=RKIND), dimension(:,:), pointer :: qvapor, relhum, theta_m, vorticity + real (kind=RKIND), dimension(:,:), pointer :: umeridional, uzonal, vvel + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + + real (kind=RKIND), dimension(:), pointer :: temperature_200hPa + real (kind=RKIND), dimension(:), pointer :: temperature_500hPa + real (kind=RKIND), dimension(:), pointer :: temperature_700hPa + real (kind=RKIND), dimension(:), pointer :: temperature_850hPa + + real (kind=RKIND), dimension(:), pointer :: relhum_200hPa + real (kind=RKIND), dimension(:), pointer :: relhum_500hPa + real (kind=RKIND), dimension(:), pointer :: relhum_700hPa + real (kind=RKIND), dimension(:), pointer :: relhum_850hPa + + real (kind=RKIND), dimension(:), pointer :: uzonal_200hPa + real (kind=RKIND), dimension(:), pointer :: uzonal_500hPa + real (kind=RKIND), dimension(:), pointer :: uzonal_700hPa + real (kind=RKIND), dimension(:), pointer :: uzonal_850hPa + + real (kind=RKIND), dimension(:), pointer :: umeridional_200hPa + real (kind=RKIND), dimension(:), pointer :: umeridional_500hPa + real (kind=RKIND), dimension(:), pointer :: umeridional_700hPa + real (kind=RKIND), dimension(:), pointer :: umeridional_850hPa + + real (kind=RKIND), dimension(:), pointer :: height_200hPa + real (kind=RKIND), dimension(:), pointer :: height_500hPa + real (kind=RKIND), dimension(:), pointer :: height_700hPa + real (kind=RKIND), dimension(:), pointer :: height_850hPa + + real (kind=RKIND), dimension(:), pointer :: w_200hPa + real (kind=RKIND), dimension(:), pointer :: w_500hPa + real (kind=RKIND), dimension(:), pointer :: w_700hPa + real (kind=RKIND), dimension(:), pointer :: w_850hPa + + real (kind=RKIND), dimension(:), pointer :: vorticity_200hPa + real (kind=RKIND), dimension(:), pointer :: vorticity_500hPa + real (kind=RKIND), dimension(:), pointer :: vorticity_700hPa + real (kind=RKIND), dimension(:), pointer :: vorticity_850hPa + + real (kind=RKIND), dimension(:,:), allocatable :: pressure, pressureCp1, pressure2, pressure_v, temperature !local interpolated fields: - integer:: nIntP - real(kind=RKIND):: w1,w2,z0,z1,z2 - real(kind=RKIND),dimension(:,:),allocatable:: field_in,press_in - real(kind=RKIND),dimension(:,:),allocatable:: field_interp,press_interp + integer :: nIntP + real (kind=RKIND) :: w1,w2,z0,z1,z2 + real (kind=RKIND), dimension(:,:), allocatable :: field_in,press_in + real (kind=RKIND), dimension(:,:), allocatable :: field_interp,press_interp !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine interp_diagnostics:' +! write(0,*) +! write(0,*) '--- enter subroutine interp_diagnostics:' + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels -!nVertLevelsP1 = mesh % nVertLevelsP1 - nVertices = mesh % nVertices - VertexDegree = mesh % vertexDegree nVertLevelsP1 = nVertLevels + 1 - cellsOnVertex => mesh % cellsOnVertex % array - areaTriangle => mesh % areaTriangle % array - kiteAreasOnVertex => mesh % kiteAreasOnVertex % array + call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) - height => mesh % zgrid % array - vvel => state % w % array - theta_m => state % theta_m % array - qvapor => state % scalars % array(state%index_qv,:,:) - - exner => diag % exner % array - pressure_b => diag % pressure_base % array - pressure_p => diag % pressure_p % array - vorticity => diag % vorticity % array - umeridional => diag % uReconstructMeridional % array - uzonal => diag % uReconstructZonal % array + call mpas_pool_get_array(mesh, 'zgrid', height) + call mpas_pool_get_array(state, 'w', vvel, time_lev) + call mpas_pool_get_array(state, 'theta_m', theta_m, time_lev) + call mpas_pool_get_array(state, 'scalars', scalars, time_lev) - relhum => diag_physics % relhum % array + qvapor => scalars(index_qv,:,:) !MGD does this actually work? + + call mpas_pool_get_field(diag, 'pressure_p', pressure_p_field) + call mpas_dmpar_exch_halo_field(pressure_p_field) + + call mpas_pool_get_array(diag, 'exner', exner) + call mpas_pool_get_array(diag, 'pressure_base', pressure_b) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array(diag, 'vorticity', vorticity) + call mpas_pool_get_array(diag, 'uReconstructMeridional', umeridional) + call mpas_pool_get_array(diag, 'uReconstructZonal', uzonal) + call mpas_pool_get_array(diag_physics, 'relhum', relhum) + + call mpas_pool_get_array(diag, 'temperature_200hPa', temperature_200hPa) + call mpas_pool_get_array(diag, 'temperature_500hPa', temperature_500hPa) + call mpas_pool_get_array(diag, 'temperature_700hPa', temperature_700hPa) + call mpas_pool_get_array(diag, 'temperature_850hPa', temperature_850hPa) + + call mpas_pool_get_array(diag, 'relhum_200hPa', relhum_200hPa) + call mpas_pool_get_array(diag, 'relhum_500hPa', relhum_500hPa) + call mpas_pool_get_array(diag, 'relhum_700hPa', relhum_700hPa) + call mpas_pool_get_array(diag, 'relhum_850hPa', relhum_850hPa) + + call mpas_pool_get_array(diag, 'uzonal_200hPa', uzonal_200hPa) + call mpas_pool_get_array(diag, 'uzonal_500hPa', uzonal_500hPa) + call mpas_pool_get_array(diag, 'uzonal_700hPa', uzonal_700hPa) + call mpas_pool_get_array(diag, 'uzonal_850hPa', uzonal_850hPa) + + call mpas_pool_get_array(diag, 'umeridional_200hPa', umeridional_200hPa) + call mpas_pool_get_array(diag, 'umeridional_500hPa', umeridional_500hPa) + call mpas_pool_get_array(diag, 'umeridional_700hPa', umeridional_700hPa) + call mpas_pool_get_array(diag, 'umeridional_850hPa', umeridional_850hPa) + + call mpas_pool_get_array(diag, 'height_200hPa', height_200hPa) + call mpas_pool_get_array(diag, 'height_500hPa', height_500hPa) + call mpas_pool_get_array(diag, 'height_700hPa', height_700hPa) + call mpas_pool_get_array(diag, 'height_850hPa', height_850hPa) + + call mpas_pool_get_array(diag, 'w_200hPa', w_200hPa) + call mpas_pool_get_array(diag, 'w_500hPa', w_500hPa) + call mpas_pool_get_array(diag, 'w_700hPa', w_700hPa) + call mpas_pool_get_array(diag, 'w_850hPa', w_850hPa) + + call mpas_pool_get_array(diag, 'vorticity_200hPa', vorticity_200hPa) + call mpas_pool_get_array(diag, 'vorticity_500hPa', vorticity_500hPa) + call mpas_pool_get_array(diag, 'vorticity_700hPa', vorticity_700hPa) + call mpas_pool_get_array(diag, 'vorticity_850hPa', vorticity_850hPa) if(.not.allocated(pressure) ) allocate(pressure(nVertLevels,nCells) ) if(.not.allocated(pressureCp1) ) allocate(pressureCp1(nVertLevels,nCells+1) ) @@ -175,11 +257,11 @@ subroutine interp_diagnostics(mesh,state,diag,diag_physics) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - diag % temperature_200hPa % array(1:nCells) = field_interp(1:nCells,1) - diag % temperature_500hPa % array(1:nCells) = field_interp(1:nCells,2) - diag % temperature_700hPa % array(1:nCells) = field_interp(1:nCells,3) - diag % temperature_850hPa % array(1:nCells) = field_interp(1:nCells,4) - write(0,*) '--- end interpolate temperature:' + temperature_200hPa(1:nCells) = field_interp(1:nCells,1) + temperature_500hPa(1:nCells) = field_interp(1:nCells,2) + temperature_700hPa(1:nCells) = field_interp(1:nCells,3) + temperature_850hPa(1:nCells) = field_interp(1:nCells,4) +! write(0,*) '--- end interpolate temperature:' !... relative humidity: do iCell = 1, nCells @@ -189,11 +271,11 @@ subroutine interp_diagnostics(mesh,state,diag,diag_physics) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - diag % relhum_200hPa % array(1:nCells) = field_interp(1:nCells,1) - diag % relhum_500hPa % array(1:nCells) = field_interp(1:nCells,2) - diag % relhum_700hPa % array(1:nCells) = field_interp(1:nCells,3) - diag % relhum_850hPa % array(1:nCells) = field_interp(1:nCells,4) - write(0,*) '--- end interpolate relative humidity:' + relhum_200hPa(1:nCells) = field_interp(1:nCells,1) + relhum_500hPa(1:nCells) = field_interp(1:nCells,2) + relhum_700hPa(1:nCells) = field_interp(1:nCells,3) + relhum_850hPa(1:nCells) = field_interp(1:nCells,4) +! write(0,*) '--- end interpolate relative humidity:' !... u zonal wind: do iCell = 1, nCells @@ -203,11 +285,11 @@ subroutine interp_diagnostics(mesh,state,diag,diag_physics) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - diag % uzonal_200hPa % array(1:nCells) = field_interp(1:nCells,1) - diag % uzonal_500hPa % array(1:nCells) = field_interp(1:nCells,2) - diag % uzonal_700hPa % array(1:nCells) = field_interp(1:nCells,3) - diag % uzonal_850hPa % array(1:nCells) = field_interp(1:nCells,4) - write(0,*) '--- end interpolate zonal wind:' + uzonal_200hPa(1:nCells) = field_interp(1:nCells,1) + uzonal_500hPa(1:nCells) = field_interp(1:nCells,2) + uzonal_700hPa(1:nCells) = field_interp(1:nCells,3) + uzonal_850hPa(1:nCells) = field_interp(1:nCells,4) +! write(0,*) '--- end interpolate zonal wind:' !... u meridional wind: do iCell = 1, nCells @@ -217,11 +299,11 @@ subroutine interp_diagnostics(mesh,state,diag,diag_physics) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - diag % umeridional_200hPa % array(1:nCells) = field_interp(1:nCells,1) - diag % umeridional_500hPa % array(1:nCells) = field_interp(1:nCells,2) - diag % umeridional_700hPa % array(1:nCells) = field_interp(1:nCells,3) - diag % umeridional_850hPa % array(1:nCells) = field_interp(1:nCells,4) - write(0,*) '--- end interpolate meridional wind:' + umeridional_200hPa(1:nCells) = field_interp(1:nCells,1) + umeridional_500hPa(1:nCells) = field_interp(1:nCells,2) + umeridional_700hPa(1:nCells) = field_interp(1:nCells,3) + umeridional_850hPa(1:nCells) = field_interp(1:nCells,4) +! write(0,*) '--- end interpolate meridional wind:' if(allocated(field_in)) deallocate(field_in) if(allocated(press_in)) deallocate(press_in) @@ -245,11 +327,11 @@ subroutine interp_diagnostics(mesh,state,diag,diag_physics) enddo enddo call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp) - diag % height_200hPa % array(1:nCells) = field_interp(1:nCells,1) - diag % height_500hPa % array(1:nCells) = field_interp(1:nCells,2) - diag % height_700hPa % array(1:nCells) = field_interp(1:nCells,3) - diag % height_850hPa % array(1:nCells) = field_interp(1:nCells,4) - write(0,*) '--- end interpolate height:' + height_200hPa(1:nCells) = field_interp(1:nCells,1) + height_500hPa(1:nCells) = field_interp(1:nCells,2) + height_700hPa(1:nCells) = field_interp(1:nCells,3) + height_850hPa(1:nCells) = field_interp(1:nCells,4) +! write(0,*) '--- end interpolate height:' !... vertical velocity do iCell = 1, nCells @@ -259,11 +341,11 @@ subroutine interp_diagnostics(mesh,state,diag,diag_physics) enddo enddo call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp) - diag % w_200hPa % array(1:nCells) = field_interp(1:nCells,1) - diag % w_500hPa % array(1:nCells) = field_interp(1:nCells,2) - diag % w_700hPa % array(1:nCells) = field_interp(1:nCells,3) - diag % w_850hPa % array(1:nCells) = field_interp(1:nCells,4) - write(0,*) '--- end interpolate vertical velocity:' + w_200hPa(1:nCells) = field_interp(1:nCells,1) + w_500hPa(1:nCells) = field_interp(1:nCells,2) + w_700hPa(1:nCells) = field_interp(1:nCells,3) + w_850hPa(1:nCells) = field_interp(1:nCells,4) +! write(0,*) '--- end interpolate vertical velocity:' if(allocated(field_interp)) deallocate(field_interp) if(allocated(press_interp)) deallocate(press_interp) @@ -299,11 +381,11 @@ subroutine interp_diagnostics(mesh,state,diag,diag_physics) enddo enddo call interp_tofixed_pressure(nVertices,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - diag % vorticity_200hPa % array(1:nVertices) = field_interp(1:nVertices,1) - diag % vorticity_500hPa % array(1:nVertices) = field_interp(1:nVertices,2) - diag % vorticity_700hPa % array(1:nVertices) = field_interp(1:nVertices,3) - diag % vorticity_850hPa % array(1:nVertices) = field_interp(1:nVertices,4) - write(0,*) '--- end interpolate relative vorticity:' + vorticity_200hPa(1:nVertices) = field_interp(1:nVertices,1) + vorticity_500hPa(1:nVertices) = field_interp(1:nVertices,2) + vorticity_700hPa(1:nVertices) = field_interp(1:nVertices,3) + vorticity_850hPa(1:nVertices) = field_interp(1:nVertices,4) +! write(0,*) '--- end interpolate relative vorticity:' if(allocated(field_interp)) deallocate(field_interp) if(allocated(press_interp)) deallocate(press_interp) diff --git a/src/core_atmosphere/mpas_atm_mpas_core.F b/src/core_atmosphere/mpas_atm_mpas_core.F index b2ac2a964f..19f44fbfa6 100644 --- a/src/core_atmosphere/mpas_atm_mpas_core.F +++ b/src/core_atmosphere/mpas_atm_mpas_core.F @@ -9,109 +9,152 @@ module mpas_core use mpas_framework - type (io_output_object), save :: restart_obj - type (io_input_object), save :: sfc_update_obj - integer :: current_outfile_frames - - type (MPAS_Clock_type) :: clock + type (MPAS_Clock_type), pointer :: clock - integer, parameter :: outputAlarmID = 1 - integer, parameter :: restartAlarmID = 2 - integer, parameter :: sfcAlarmID = 3 - integer, parameter :: hifreqAlarmID = 4 contains - subroutine mpas_core_init(domain, startTimeStamp) + subroutine mpas_core_init(domain, stream_manager, startTimeStamp) - use mpas_configure use mpas_kind_types + use mpas_stream_manager use mpas_grid_types implicit none type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager character(len=*), intent(out) :: startTimeStamp - real (kind=RKIND) :: dt + real (kind=RKIND), pointer :: dt type (block_type), pointer :: block character(len=StrKIND) :: timeStamp integer :: i integer :: ierr + logical, pointer :: config_do_restart + + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: diag + type (field2DReal), pointer :: u_field, pv_edge_field, ru_field, rw_field + character (len=StrKIND), pointer :: xtime + type (MPAS_Time_Type) :: startTime + + + ! + ! Set "local" clock to point to the clock contained in the domain type + ! + clock => domain % clock - if (.not. config_do_restart) then - ! Code that was previously in atm_setup_test_case() + call mpas_pool_get_config(domain % blocklist % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', dt) + + ! + ! If this is a restart run, read the restart stream, else read the input + ! stream. + ! Regardless of which stream we read for initial conditions, reset the + ! input alarms for both input and restart before reading any remaining + ! input streams. + ! + if (config_do_restart) then + call MPAS_stream_mgr_read(stream_manager, streamID='restart', ierr=ierr) + else + call MPAS_stream_mgr_read(stream_manager, streamID='input', ierr=ierr) + end if + if (ierr /= MPAS_STREAM_MGR_NOERR) then + write(0,*) ' ' + write(0,*) '********************************************************************************' + write(0,*) 'Error reading initial conditions' + call mpas_dmpar_global_abort('********************************************************************************') + end if + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='input', direction=MPAS_STREAM_INPUT, ierr=ierr) + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='restart', direction=MPAS_STREAM_INPUT, ierr=ierr) + + ! + ! Read all other inputs + ! For now we don't do this here to match results with previous code; to match requires + ! that we read in SST and seaice fields after the call to atm_mpas_init_block() + ! +! call MPAS_stream_mgr_read(stream_manager, ierr=ierr) +! call MPAS_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_INPUT, ierr=ierr) + + if (.not. config_do_restart) then 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 + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_initialize_time_levels(state) block => block % next end do - end if ! - ! Initialize core + ! Set startTimeStamp based on the start time of the simulation clock ! - dt = config_dt + startTime = mpas_get_clock_time(clock, MPAS_START_TIME, ierr) + call mpas_get_time(startTime, dateTimeString=startTimeStamp) - call atm_simulation_clock_init(domain, dt, startTimeStamp) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(1) % state % u) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_field(state, 'u', u_field, 1) + call mpas_dmpar_exch_halo_field(u_field) block => domain % blocklist do while (associated(block)) - call atm_mpas_init_block(domain % dminfo, block, block % mesh, dt) - block % state % time_levs(1) % state % xtime % scalar = startTimeStamp - block => block % next - end do - - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % pv_edge) - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % ru) - call mpas_dmpar_exch_halo_field(domain % blocklist % diag % rw) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) - current_outfile_frames = 0 + call atm_mpas_init_block(domain % dminfo, stream_manager, block, mesh, dt) - if (config_sfc_update_interval /= "none") then + call mpas_pool_get_array(state, 'xtime', xtime, 1) + xtime = startTimeStamp - sfc_update_obj % filename = trim(config_sfc_update_name) - sfc_update_obj % stream = STREAM_SFC - - call mpas_io_input_init(sfc_update_obj, domain % blocklist, domain % dminfo) + block => block % next + end do - ! - ! We need to decide which time slice to read from the surface file - read the most recent time slice that falls before or on the start time - ! - sfc_update_obj % time = MPAS_seekStream(sfc_update_obj % io_stream, trim(startTimeStamp), MPAS_STREAM_LATEST_BEFORE, timeStamp, ierr) - if (ierr == MPAS_IO_ERR) then - write(0,*) 'Error: surface update file '//trim(sfc_update_obj % filename)//' did not contain any times at or before '//trim(startTimeStamp) - call mpas_dmpar_abort(domain % dminfo) - end if + call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_field(diag, 'pv_edge', pv_edge_field) + call mpas_dmpar_exch_halo_field(pv_edge_field) - write(0,*) 'Starting model with surface time ', trim(timeStamp) + call mpas_pool_get_field(diag, 'ru', ru_field) + call mpas_dmpar_exch_halo_field(ru_field) - end if + call mpas_pool_get_field(diag, 'rw', rw_field) + call mpas_dmpar_exch_halo_field(rw_field) end subroutine mpas_core_init - subroutine atm_simulation_clock_init(domain, dt, startTimeStamp) + subroutine atm_simulation_clock_init(core_clock, configs, ierr) implicit none - type (domain_type), intent(inout) :: domain - real (kind=RKIND), intent(in) :: dt - character(len=*), intent(out) :: startTimeStamp + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep - integer :: ierr + integer :: local_err + real (kind=RKIND), pointer :: config_dt + character (len=StrKIND), pointer :: config_start_time + character (len=StrKIND), pointer :: config_restart_timestamp_name + character (len=StrKIND), pointer :: config_run_duration + character (len=StrKIND), pointer :: config_stop_time + character (len=StrKIND) :: startTimeStamp + + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_dt', config_dt) + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_restart_timestamp_name', config_restart_timestamp_name) + call mpas_pool_get_config(configs, 'config_run_duration', config_run_duration) + call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) if(trim(config_start_time) == 'file') then open(22,file=trim(config_restart_timestamp_name),form='formatted',status='old') @@ -120,70 +163,41 @@ subroutine atm_simulation_clock_init(domain, dt, startTimeStamp) else startTimeStamp = config_start_time end if - call mpas_set_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr) - call mpas_set_timeInterval(timeStep, dt=dt, ierr=ierr) + call mpas_set_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=local_err) + call mpas_set_timeInterval(timeStep, dt=config_dt, ierr=local_err) 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) + call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=local_err) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=local_err) if (trim(config_stop_time) /= "none") then - call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr) + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=local_err) if(startTime + runduration /= stopTime) then write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.' end if end if else if (trim(config_stop_time) /= "none") then - call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr) - call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr) + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=local_err) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=local_err) else - write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' - call mpas_dmpar_abort(domain % dminfo) - end if - - ! set output alarm - call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) - - ! set restart alarm, if necessary - if (trim(config_restart_interval) /= "none") then - call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) + write(stderrUnit,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' + ierr = 1 end if - ! set high-frequency history alarm, if necessary - if (trim(config_hifreq_output_interval) /= "none") then - call mpas_set_timeInterval(alarmTimeStep, timeString=config_hifreq_output_interval, ierr=ierr) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, hifreqAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) - end if - - ! set sfc alarm, if necessary - if (trim(config_sfc_update_interval) /= "none") then - call mpas_set_timeInterval(alarmTimeStep, timeString=config_sfc_update_interval, ierr=ierr) - alarmStartTime = startTime - call mpas_add_clock_alarm(clock, sfcAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) - end if - !TODO: set phyics alarms here... !.... !.... - call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr) - end subroutine atm_simulation_clock_init - subroutine atm_mpas_init_block(dminfo, block, mesh, dt) + subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) use mpas_grid_types - ! use atm_advection use atm_time_integration - use mpas_configure use mpas_rbf_interpolation use mpas_vector_reconstruction + use mpas_stream_manager #ifdef DO_PHYSICS ! use mpas_atmphys_aquaplanet use mpas_atmphys_control @@ -194,110 +208,174 @@ subroutine atm_mpas_init_block(dminfo, block, mesh, dt) implicit none type (dm_info), intent(in) :: dminfo + type (MPAS_streamManager_type), intent(inout) :: stream_manager type (block_type), intent(inout) :: block - type (mesh_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: mesh !MGD does this need to be a pointer? real (kind=RKIND), intent(in) :: dt + + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: sfc_input + type (mpas_pool_type), pointer :: diag_physics + type (mpas_pool_type), pointer :: atm_input + + real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional + real (kind=RKIND), dimension(:), pointer :: meshScalingDel2, meshScalingDel4 + character(len=StrKIND), pointer :: mminlu + + integer, pointer :: nEdgesSolve + logical, pointer :: config_do_restart, config_do_DAcycling + + + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'state', state) + + call mpas_pool_get_config(block % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(block % configs, 'config_do_DAcycling', config_do_DAcycling) + if (.not. config_do_restart .or. (config_do_restart .and. config_do_DAcycling)) then - call atm_init_coupled_diagnostics( block % state % time_levs(1) % state, block % diag, mesh) + call atm_init_coupled_diagnostics( state, 1, diag, mesh, block % configs) end if - call atm_compute_solve_diagnostics(dt, block % state % time_levs(1) % state, block % diag, mesh) + call atm_compute_solve_diagnostics(dt, state, 1, diag, mesh, block % configs) call mpas_rbf_interp_initialize(mesh) call mpas_init_reconstruct(mesh) - call mpas_reconstruct(mesh, block % state % time_levs(1) % state % u % array, & - block % diag % uReconstructX % array, & - block % diag % uReconstructY % array, & - block % diag % uReconstructZ % array, & - block % diag % uReconstructZonal % array, & - block % diag % uReconstructMeridional % array & + + call mpas_pool_get_array(state, 'u', u, 1) + call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + call mpas_reconstruct(mesh, u, & + uReconstructX, & + uReconstructY, & + uReconstructZ, & + uReconstructZonal, & + uReconstructMeridional & ) - ! - ! Note: The following initialization calls have been moved to mpas_setup_test_case() - ! since values computed by these routines are needed to produce initial fields - ! - ! call atm_initialize_advection_rk(mesh) - ! call atm_initialize_deformation_weights(mesh) - #ifdef DO_PHYSICS !check that all the physics options are correctly defined and that at least one physics !parameterization is called (using the logical moist_physics): - call physics_namelist_check + call physics_namelist_check(mesh, block % configs) !proceed with initialization of physics parameterization if moist_physics is set to true: - if(moist_physics) then - !initialization of seom input variables in registry: - call physics_registry_init(config_do_restart, mesh, block % sfc_input) - call physics_run_init(mesh,block % state % time_levs(1) % state,clock) + call mpas_pool_get_subpool(block % structs, 'sfc_input', sfc_input) + + ! Before calling physics_init, ensure that mminlu contains the name of the land use dataset + call mpas_pool_get_array(sfc_input, 'mminlu', mminlu) + if (len_trim(mminlu) == 0) then + write(0,*) '****************************************************************' + write(0,*) 'No information on land use dataset is available.' + write(0,*) 'Assume that we are using ''USGS''.' + write(0,*) '****************************************************************' + write(mminlu,'(a)') 'USGS' + end if - !initialization of all physics: - call physics_init(dminfo, clock, config_do_restart, mesh, block % diag, & - block % state % time_levs(1) % state, & - block % state % time_levs(1) % state, & - block % diag_physics, block % atm_input, & - block % sfc_input) + if (moist_physics) then + !initialization of some input variables in registry: + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block % structs, 'atm_input', atm_input) + call physics_registry_init(mesh, block % configs, sfc_input) + call physics_run_init(block % configs, mesh, state, clock, stream_manager) + + !initialization of all physics: + call physics_init(dminfo, clock, block % configs, mesh, diag, tend, state, 1, diag_physics, & + atm_input, sfc_input) endif #endif - call atm_compute_mesh_scaling(mesh) + call atm_compute_mesh_scaling(mesh, block % configs) + + call atm_compute_damping_coefs(mesh, block % configs) - call atm_compute_damping_coefs(mesh) + call atm_compute_pgf_coefs(mesh, block % configs) - call atm_compute_pgf_coefs(mesh) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) - write(0,*) 'min/max of meshScalingDel2 = ', minval(mesh % meshScalingDel2 % array(1:mesh%nEdges)), & - maxval(mesh % meshScalingDel2 % array(1:mesh%nEdges)) - write(0,*) 'min/max of meshScalingDel4 = ', minval(mesh % meshScalingDel4 % array(1:mesh%nEdges)), & - maxval(mesh % meshScalingDel4 % array(1:mesh%nEdges)) + write(0,*) 'min/max of meshScalingDel2 = ', minval(meshScalingDel2(1:nEdgesSolve)), & + maxval(meshScalingDel2(1:nEdgesSolve)) + write(0,*) 'min/max of meshScalingDel4 = ', minval(meshScalingDel4(1:nEdgesSolve)), & + maxval(meshScalingDel4(1:nEdgesSolve)) call atm_adv_coef_compression(mesh) - + end subroutine atm_mpas_init_block - subroutine mpas_core_run(domain, output_obj, output_frame) + subroutine mpas_core_run(domain, stream_manager) use mpas_grid_types use mpas_kind_types - use mpas_io_output - use mpas_io_input, only: insert_string_suffix => mpas_insert_string_suffix + use mpas_stream_manager + use mpas_io_streams, only : MPAS_STREAM_LATEST_BEFORE use mpas_timer implicit none type (domain_type), intent(inout) :: domain - type (io_output_object), intent(inout) :: output_obj - integer, intent(inout) :: output_frame + type (MPAS_streamManager_type), intent(inout) :: stream_manager - real (kind=RKIND) :: dt + real (kind=RKIND), pointer :: dt + logical, pointer :: config_do_restart type (block_type), pointer :: block_ptr type (MPAS_Time_Type) :: currTime character(len=StrKIND) :: timeStamp + character (len=StrKIND), pointer :: config_restart_timestamp_name integer :: itimestep integer :: ierr + type (mpas_pool_type), pointer :: state, diag, diag_physics, mesh + ! For high-frequency diagnostics output character (len=StrKIND) :: tempfilename - ! Eventually, dt should be domain specific - dt = config_dt - call atm_write_output_frame(output_obj, output_frame, domain) - if (trim(config_hifreq_output_interval) /= 'none') then - block_ptr => domain % blocklist - call atm_compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % diag, & - block_ptr % diag_physics, block_ptr % mesh) + ! Eventually, dt should be domain specific + call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', dt) + call mpas_pool_get_config(domain % blocklist % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(domain % blocklist % configs, 'config_restart_timestamp_name', config_restart_timestamp_name) - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) + ! Avoid writing a restart file at the initial time + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + + ! Also, for restart runs, avoid writing the initial history fields to avoid overwriting those from the preceding run + if (config_do_restart) then + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='output', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + end if - call insert_string_suffix('diagnostics.nc', trim(timeStamp), tempfilename) - call write_hifreq_output(block_ptr, tempfilename) + if (MPAS_stream_mgr_ringing_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call atm_compute_output_diagnostics(state, 1, diag, diag_physics, mesh) + + block_ptr => block_ptr % next + end do + end if + call mpas_stream_mgr_write(stream_manager, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR .and. & + ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_FILE .and. & + ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_REC) then + write(0,*) ' ' + write(0,*) '********************************************************************************' + write(0,*) 'Error writing one or more output streams' + call mpas_dmpar_global_abort('********************************************************************************') end if + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) + ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) @@ -306,119 +384,97 @@ subroutine mpas_core_run(domain, output_obj, output_frame) currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) - write(0,*) 'Begin timestep ', trim(timeStamp) - ! Input external updates (i.e. surface) - if (mpas_is_alarm_ringing(clock, sfcAlarmID, ierr=ierr)) then - call mpas_reset_clock_alarm(clock, sfcAlarmID, ierr=ierr) + write(0,*) ' ' + write(0,*) 'Begin timestep ', trim(timeStamp) - call mpas_read_and_distribute_fields(sfc_update_obj) - sfc_update_obj % time = sfc_update_obj % time + 1 + ! + ! Read external field updates + ! + call MPAS_stream_mgr_read(stream_manager, whence=MPAS_STREAM_LATEST_BEFORE, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + write(0,*) ' ' + write(0,*) '********************************************************************************' + write(0,*) 'Error reading one or more input streams' + call mpas_dmpar_global_abort('********************************************************************************') end if + call MPAS_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_INPUT, ierr=ierr) call mpas_timer_start("time integration") call atm_do_timestep(domain, dt, itimestep) call mpas_timer_stop("time integration") ! Move time level 2 fields back into time level 1 for next time step - call mpas_shift_time_levels_state(domain % blocklist % state) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_shift_time_levels(state) - ! Advance clock before writing output itimestep = itimestep + 1 call mpas_advance_clock(clock) currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) - - !TODO: MPAS_getClockRingingAlarms is probably faster than multiple MPAS_isAlarmRinging... - 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 - 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)) - end if - call atm_write_output_frame(output_obj, output_frame, domain) - end if - - if (mpas_is_alarm_ringing(clock, hifreqAlarmID, ierr=ierr)) then - call mpas_reset_clock_alarm(clock, hifreqAlarmID, ierr=ierr) + ! + ! Write any output streams that have alarms ringing, after computing diagnostics fields + ! + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) + if (MPAS_stream_mgr_ringing_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then block_ptr => domain % blocklist - call atm_compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % diag, & - block_ptr % diag_physics, block_ptr % mesh) - - call insert_string_suffix('diagnostics.nc', trim(timeStamp), tempfilename) - call write_hifreq_output(block_ptr, tempfilename) - end if + do while (associated(block_ptr)) - if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then - call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call atm_compute_output_diagnostics(state, 1, diag, diag_physics, mesh) + block_ptr => block_ptr % next + end do + end if + if (MPAS_stream_mgr_ringing_alarms(stream_manager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then block_ptr => domain % blocklist do while (associated(block_ptr)) - call atm_compute_restart_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % diag, block_ptr % mesh) + + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call atm_compute_restart_diagnostics(state, 1, diag, mesh) + block_ptr => block_ptr % next end do + end if + + call mpas_stream_mgr_write(stream_manager, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR .and. & + ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_FILE .and. & + ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_REC) then + write(0,*) ' ' + write(0,*) '********************************************************************************' + write(0,*) 'Error writing one or more output streams' + call mpas_dmpar_global_abort('********************************************************************************') + end if - ! Write one restart time per file - call mpas_output_state_init(restart_obj, domain, "RESTART", trim(timeStamp)) - call mpas_output_state_for_domain(restart_obj, domain, 1) - call mpas_output_state_finalize(restart_obj, domain % dminfo) + ! Only after we've successfully written the restart file should we we + ! write the restart_timestamp file + if (MPAS_stream_mgr_ringing_alarms(stream_manager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then + open(22,file=trim(config_restart_timestamp_name),form='formatted',status='replace') + write(22,*) trim(timeStamp) + close(22) end if + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) + end do end subroutine mpas_core_run - subroutine atm_write_output_frame(output_obj, output_frame, domain) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Compute diagnostic fields for a domain and write model state to output file - ! - ! Input/Output: domain - contains model state; diagnostic field are computed - ! before returning - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_grid_types - use mpas_io_output - - implicit none - - integer, intent(inout) :: output_frame - type (domain_type), intent(inout) :: domain - type (io_output_object), intent(inout) :: output_obj - - type (block_type), pointer :: block_ptr - - block_ptr => domain % blocklist - do while (associated(block_ptr)) - call atm_compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % diag, & - block_ptr % diag_physics, block_ptr % mesh) - block_ptr => block_ptr % next - end do - - call mpas_output_state_for_domain(output_obj, domain, output_frame) - output_frame = output_frame + 1 - - ! reset frame if the maximum number of frames per outfile has been reached - if (config_frames_per_outfile > 0) then - current_outfile_frames = current_outfile_frames + 1 - if(current_outfile_frames >= config_frames_per_outfile) then - current_outfile_frames = 0 - output_frame = 1 - end if - end if - - end subroutine atm_write_output_frame - - - subroutine atm_compute_output_diagnostics(state, diag, diag_physics, grid) + subroutine atm_compute_output_diagnostics(state, time_lev, diag, diag_physics, mesh) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Compute diagnostic fields for a domain to be written to history files ! ! Input: state - contains model prognostic fields - ! grid - contains grid metadata + ! mesh - contains grid metadata ! ! Output: state - upon returning, diagnostic fields will have be computed !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -429,31 +485,53 @@ subroutine atm_compute_output_diagnostics(state, diag, diag_physics, grid) implicit none - type (state_type), intent(inout) :: state - type (diag_type), intent(inout) :: diag - type (diag_physics_type), intent(inout) :: diag_physics - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(inout) :: state + integer, intent(in) :: time_lev ! which time level to use from state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: diag_physics + type (mpas_pool_type), intent(in) :: mesh integer :: iCell, k - - do iCell=1,grid%nCells - do k=1,grid%nVertLevels - diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1._RKIND + rvord * state % scalars % array(state % index_qv,k,iCell)) - diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * grid % zz % array(k,iCell) + integer, pointer :: nCells, nVertLevels, index_qv + real (kind=RKIND), dimension(:,:), pointer :: theta, rho, theta_m, rho_zz, zz + real (kind=RKIND), dimension(:,:), pointer :: pressure_base, pressure_p, pressure + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + + call mpas_pool_get_array(state, 'theta_m', theta_m, time_lev) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, time_lev) + call mpas_pool_get_array(state, 'scalars', scalars, time_lev) + + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array(diag, 'pressure_base', pressure_base) + call mpas_pool_get_array(diag, 'pressure', pressure) + + call mpas_pool_get_array(mesh, 'zz', zz) + + do iCell=1,nCells + do k=1,nVertLevels + theta(k,iCell) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + pressure(k,iCell) = pressure_base(k,iCell) + pressure_p(k,iCell) end do end do - call interp_diagnostics(grid,state,diag,diag_physics) + call interp_diagnostics(mesh, state, time_lev, diag, diag_physics) end subroutine atm_compute_output_diagnostics - subroutine atm_compute_restart_diagnostics(state, diag, grid) + subroutine atm_compute_restart_diagnostics(state, time_lev, diag, mesh) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Compute diagnostic fields for a domain to be written to restart files ! ! Input: state - contains model prognostic fields - ! grid - contains grid metadata + ! mesh - contains grid metadata ! ! Output: state - upon returning, diagnostic fields will have be computed !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -463,76 +541,39 @@ subroutine atm_compute_restart_diagnostics(state, diag, grid) implicit none - type (state_type), intent(inout) :: state - type (diag_type), intent(inout) :: diag - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(inout) :: state + integer, intent(in) :: time_lev ! which time level to use from state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: mesh integer :: iCell, k + integer, pointer :: nCells, nVertLevels, index_qv + real (kind=RKIND), dimension(:,:), pointer :: theta, rho, theta_m, rho_zz, zz + real (kind=RKIND), dimension(:,:,:), pointer :: scalars - do iCell=1,grid%nCells - do k=1,grid%nVertLevels - diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1._RKIND + rvord * state % scalars % array(state % index_qv,k,iCell)) - diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * grid % zz % array(k,iCell) - end do - end do - - end subroutine atm_compute_restart_diagnostics + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_array(state, 'theta_m', theta_m, time_lev) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, time_lev) + call mpas_pool_get_array(state, 'scalars', scalars, time_lev) - subroutine write_hifreq_output(block_ptr, fname) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(diag, 'rho', rho) - implicit none - - type (block_type), pointer :: block_ptr - character (len=*), intent(in) :: fname + call mpas_pool_get_array(mesh, 'zz', zz) - integer :: ierr - type (MPAS_Stream_type) :: hifreq_stream + do iCell=1,nCells + do k=1,nVertLevels + theta(k,iCell) = theta_m(k,iCell) / (1.0_RKIND + rvord * scalars(index_qv,k,iCell)) + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + end do + end do + + end subroutine atm_compute_restart_diagnostics - call MPAS_createStream(hifreq_stream, trim(fname), MPAS_IO_PNETCDF, MPAS_IO_WRITE, 1, ierr) - if (block_ptr % mesh % on_a_sphere) then - call MPAS_writeStreamAtt(hifreq_stream, 'on_a_sphere', 'YES ', ierr) - else - call MPAS_writeStreamAtt(hifreq_stream, 'on_a_sphere', 'NO ', ierr) - end if - call MPAS_writeStreamAtt(hifreq_stream, 'sphere_radius', block_ptr % mesh % sphere_radius, ierr) - call MPAS_writeStreamAtt(hifreq_stream, 'model_name', block_ptr % domain % modelName, ierr) - call MPAS_writeStreamAtt(hifreq_stream, 'core_name', block_ptr % domain % coreName, ierr) - call MPAS_writeStreamAtt(hifreq_stream, 'model_version', block_ptr % domain % modelVersion, ierr) - call MPAS_writeStreamAtt(hifreq_stream, 'source', 'MPAS', ierr) - call MPAS_writeStreamAtt(hifreq_stream, 'Conventions', 'MPAS', ierr) - - call MPAS_streamAddField(hifreq_stream, block_ptr % state % time_levs(1) % state % xtime, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag_physics % olrtoa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag_physics % rainc, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag_physics % rainnc, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag_physics % refl10cm_max, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag_physics % precipw, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % temperature_200hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % temperature_500hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % temperature_850hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % height_200hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % height_500hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % height_850hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % uzonal_200hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % uzonal_500hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % uzonal_850hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % umeridional_200hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % umeridional_500hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % umeridional_850hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % w_200hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % w_500hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % w_850hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % vorticity_200hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % vorticity_500hPa, ierr) - call MPAS_streamAddField(hifreq_stream, block_ptr % diag % vorticity_850hPa, ierr) - call MPAS_writeStream(hifreq_stream, 1, ierr) - call MPAS_closeStream(hifreq_stream, ierr) - - end subroutine write_hifreq_output - - subroutine atm_do_timestep(domain, dt, itimestep) use mpas_grid_types @@ -581,36 +622,45 @@ subroutine atm_do_timestep(domain, dt, itimestep) end subroutine atm_do_timestep - subroutine mpas_core_finalize(domain) + subroutine mpas_core_finalize(domain, stream_manager) use mpas_grid_types + use mpas_stream_manager implicit none type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager integer :: ierr - if (config_sfc_update_interval /= "none") call mpas_io_input_finalize(sfc_update_obj, domain % dminfo) - call mpas_destroy_clock(clock, ierr) end subroutine mpas_core_finalize - subroutine atm_compute_mesh_scaling(mesh) + subroutine atm_compute_mesh_scaling(mesh, configs) use mpas_grid_types implicit none - type (mesh_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs integer :: iEdge, cell1, cell2 + integer, pointer :: nEdges + integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:), pointer :: meshDensity, meshScalingDel2, meshScalingDel4 + logical, pointer :: config_h_ScaleWithMesh + + call mpas_pool_get_array(mesh, 'meshDensity', meshDensity) + call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - meshDensity => mesh % meshDensity % array - meshScalingDel2 => mesh % meshScalingDel2 % array - meshScalingDel4 => mesh % meshScalingDel4 % array + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + + call mpas_pool_get_config(configs, 'config_h_ScaleWithMesh', config_h_ScaleWithMesh) ! ! Compute the scaling factors to be used in the del2 and del4 dissipation @@ -618,9 +668,9 @@ subroutine atm_compute_mesh_scaling(mesh) meshScalingDel2(:) = 1.0 meshScalingDel4(:) = 1.0 if (config_h_ScaleWithMesh) then - do iEdge=1,mesh%nEdges - cell1 = mesh % cellsOnEdge % array(1,iEdge) - cell2 = mesh % cellsOnEdge % array(2,iEdge) + do iEdge=1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) meshScalingDel2(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**0.5 meshScalingDel4(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0) end do @@ -629,29 +679,38 @@ subroutine atm_compute_mesh_scaling(mesh) end subroutine atm_compute_mesh_scaling - subroutine atm_compute_damping_coefs(mesh) + subroutine atm_compute_damping_coefs(mesh, configs) use mpas_grid_types - use mpas_configure +! use mpas_configure implicit none - type (mesh_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs integer :: iCell, k + integer, pointer :: nCells, nVertLevels + real (kind=RKIND), pointer :: config_xnutr, config_zd real (kind=RKIND) :: z, zt, m1, pii real (kind=RKIND), dimension(:,:), pointer :: dss, zgrid m1 = -1.0 pii = acos(m1) - dss => mesh % dss % array - zgrid => mesh % zgrid % array + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(mesh, 'dss', dss) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + + call mpas_pool_get_config(configs, 'config_zd', config_zd) + call mpas_pool_get_config(configs, 'config_xnutr', config_xnutr) dss(:,:) = 0.0 - do iCell=1,mesh%nCells - zt = zgrid(mesh%nVertLevels+1,iCell) - do k=1,mesh%nVertLevels + do iCell=1,nCells + zt = zgrid(nVertLevels+1,iCell) + do k=1,nVertLevels z = 0.5*(zgrid(k,iCell) + zgrid(k+1,iCell)) if (z > config_zd) then dss(k,iCell) = config_xnutr*sin(0.5*pii*(z-config_zd)/(zt-config_zd))**2.0 @@ -662,24 +721,35 @@ subroutine atm_compute_damping_coefs(mesh) end subroutine atm_compute_damping_coefs - subroutine atm_compute_pgf_coefs(mesh) + subroutine atm_compute_pgf_coefs(mesh, configs) use mpas_grid_types - use mpas_configure +! use mpas_configure implicit none - type (mesh_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs integer :: iEdge, iCell1, iCell2, k, iCell, nz, nz1 real (kind=RKIND) :: d1, d2, d3 real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl, zgrid, pzp, pzm + integer, dimension(:,:), pointer :: cellsOnEdge + integer, pointer :: nCells, nEdges, nVertLevels + logical, pointer :: config_newpx - cpr => mesh % cpr % array - cpl => mesh % cpl % array - pzp => mesh % pzp % array - pzm => mesh % pzm % array - zgrid => mesh % zgrid % array + call mpas_pool_get_array(mesh, 'cpr', cpr) + call mpas_pool_get_array(mesh, 'cpl', cpl) + call mpas_pool_get_array(mesh, 'pzp', pzp) + call mpas_pool_get_array(mesh, 'pzm', pzm) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_config(configs, 'config_newpx', config_newpx) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) !**** coefficient arrays for new pressure gradient calculation @@ -687,10 +757,10 @@ subroutine atm_compute_pgf_coefs(mesh) cpl(:,:) = 0.0 if (config_newpx) then - do iEdge=1,mesh%nEdges + do iEdge=1,nEdges - iCell1 = mesh % cellsOnEdge % array(1,iEdge) - iCell2 = mesh % cellsOnEdge % array(2,iEdge) + iCell1 = cellsOnEdge(1,iEdge) + iCell2 = cellsOnEdge(2,iEdge) d1 = .25*(zgrid(1,iCell2)+zgrid(2,iCell2)-zgrid(1,iCell1)-zgrid(2,iCell1)) d2 = d1+.5*(zgrid(3,iCell2)-zgrid(1,iCell2)) @@ -725,10 +795,10 @@ subroutine atm_compute_pgf_coefs(mesh) ! Coefficients for computing vertical pressure gradient dp/dz ! dp/dz (k,iCell) = pzp(k,iCell) * (p(k+1,iCell) - p(k,iCell)) +pzm(k,iCell) * (p(k,iCell) - p(k-1,iCell)) - nz1 = mesh % nVertLevels + nz1 = nVertLevels nz = nz1 + 1 - do iCell=1, mesh % nCells + do iCell=1, nCells d1 = zgrid(3,iCell)-zgrid(1,iCell) d2 = zgrid(4,iCell)-zgrid(2,iCell) @@ -757,39 +827,47 @@ subroutine atm_compute_pgf_coefs(mesh) end subroutine atm_compute_pgf_coefs - subroutine atm_adv_coef_compression( grid ) + subroutine atm_adv_coef_compression( mesh ) implicit none - type (mesh_type), intent(inout) :: grid + type (mpas_pool_type), intent(inout) :: mesh real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd integer, dimension(:,:), pointer :: cellsOnCell, cellsOnEdge, advCellsForEdge integer, dimension(:), pointer :: nEdgesOnCell, nAdvCellsForEdge + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge integer :: cell1, cell2, iEdge, n, i, j, j_in, iCell + integer, pointer :: nCells, nEdges integer :: cell_list(20), ordered_cell_list(20) logical :: addcell - deriv_two => grid % deriv_two % array - adv_coefs => grid % adv_coefs % array - adv_coefs_3rd => grid % adv_coefs_3rd % array - cellsOnCell => grid % cellsOnCell % array - cellsOnEdge => grid % cellsOnEdge % array - advCellsForEdge => grid % advCellsForEdge % array - nEdgesOnCell => grid % nEdgesOnCell % array - nAdvCellsForEdge => grid % nAdvCellsForEdge % array - do iEdge = 1, grid % nEdges + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + + do iEdge = 1, nEdges nAdvCellsForEdge(iEdge) = 0 cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) ! ! do only if this edge flux is needed to update owned cells ! - if (cell1 <= grid%nCells .or. cell2 <= grid%nCells) then + if (cell1 <= nCells .or. cell2 <= nCells) then cell_list(1) = cell1 cell_list(2) = cell2 @@ -818,7 +896,7 @@ subroutine atm_adv_coef_compression( grid ) ! order the list by increasing cell number (brute force approach) do i=1,n - ordered_cell_list(i) = grid % nCells + 2 + ordered_cell_list(i) = nCells + 2 j_in = 1 do j=1,n if (ordered_cell_list(i) > cell_list(j) ) then @@ -827,7 +905,7 @@ subroutine atm_adv_coef_compression( grid ) end if end do ! ordered_cell_list(i) = cell_list(j_in) - cell_list(j_in) = grid % nCells + 3 + cell_list(j_in) = nCells + 3 end do nAdvCellsForEdge(iEdge) = n @@ -879,8 +957,8 @@ subroutine atm_adv_coef_compression( grid ) end do do j = 1,n - adv_coefs (j,iEdge) = - (grid % dcEdge % array (iEdge) **2) * adv_coefs (j,iEdge) / 12. - adv_coefs_3rd(j,iEdge) = - (grid % dcEdge % array (iEdge) **2) * adv_coefs_3rd(j,iEdge) / 12. + adv_coefs (j,iEdge) = - (dcEdge(iEdge) **2) * adv_coefs (j,iEdge) / 12. + adv_coefs_3rd(j,iEdge) = - (dcEdge(iEdge) **2) * adv_coefs_3rd(j,iEdge) / 12. end do ! 2nd order centered contribution - place this in the main flux weights @@ -900,8 +978,8 @@ subroutine atm_adv_coef_compression( grid ) ! multiply by edge length - thus the flux is just dt*ru times the results of the vector-vector multiply do j=1,n - adv_coefs (j,iEdge) = grid % dvEdge % array(iEdge) * adv_coefs (j,iEdge) - adv_coefs_3rd(j,iEdge) = grid % dvEdge % array(iEdge) * adv_coefs_3rd(j,iEdge) + adv_coefs (j,iEdge) = dvEdge(iEdge) * adv_coefs (j,iEdge) + adv_coefs_3rd(j,iEdge) = dvEdge(iEdge) * adv_coefs_3rd(j,iEdge) end do end if ! only do for edges of owned-cells @@ -910,30 +988,102 @@ subroutine atm_adv_coef_compression( grid ) end subroutine atm_adv_coef_compression -!*********************************************************************** -! -! routine mpas_core_setup_packages -! -!> \brief Pacakge setup routine -!> \author Doug Jacobsen -!> \date September 2011 -!> \details -!> This routine is intended to correctly configure the packages for this MPAS -!> core. It can use any Fortran logic to properly configure packages, and it -!> can also make use of any namelist options. All variables in the model are -!> *not* allocated until after this routine is called. -! -!----------------------------------------------------------------------- - subroutine mpas_core_setup_packages(ierr)!{{{ + + !*********************************************************************** + ! + ! routine mpas_core_setup_packages + ! + !> \brief Pacakge setup routine + !> \author Doug Jacobsen + !> \date September 2011 + !> \details + !> This routine is intended to correctly configure the packages for this MPAS + !> core. It can use any Fortran logic to properly configure packages, and it + !> can also make use of any namelist options. All variables in the model are + !> *not* allocated until after this routine is called. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_setup_packages(configs, packages, ierr)!{{{ use mpas_packages implicit none + type (mpas_pool_type), intent(inout) :: configs + type (mpas_pool_type), intent(inout) :: packages integer, intent(out) :: ierr ierr = 0 end subroutine mpas_core_setup_packages!}}} + + !*********************************************************************** + ! + ! routine mpas_core_setup_clock + ! + !> \brief Pacakge setup routine + !> \author Michael Duda + !> \date 6 August 2014 + !> \details + !> The purpose of this routine is to allow the core to set up a simulation + !> clock that will be used by the I/O subsystem for timing reads and writes + !> of I/O streams. + !> This routine is called from the superstructure after the framework + !> has been initialized but before any fields have been allocated and + !> initial fields have been read from input files. However, all namelist + !> options are available. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_setup_clock(core_clock, configs, ierr) + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + call atm_simulation_clock_init(core_clock, configs, ierr) + + end subroutine mpas_core_setup_clock + + + !*********************************************************************** + ! + ! routine mpas_core_get_mesh_stream + ! + !> \brief Returns the name of the stream containing mesh information + !> \author Michael Duda + !> \date 8 August 2014 + !> \details + !> This routine returns the name of the I/O stream containing dimensions, + !> attributes, and mesh fields needed by the framework bootstrapping + !> routine. At the time this routine is called, only namelist options + !> are available. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_get_mesh_stream(configs, stream, ierr) + + implicit none + + type (mpas_pool_type), intent(in) :: configs + character(len=*), intent(out) :: stream + integer, intent(out) :: ierr + + logical, pointer :: config_do_restart + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) + + if (.not. associated(config_do_restart)) then + ierr = 1 + else if (config_do_restart) then + write(stream,'(a)') 'restart' + else + write(stream,'(a)') 'input' + end if + + end subroutine mpas_core_get_mesh_stream + end module mpas_core diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index c983a5b4fc..e5e3111818 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -14,30 +14,30 @@ OBJS_init = \ mpas_atmphys_o3climatology.o OBJS = \ - mpas_atmphys_camrad_init.o \ - mpas_atmphys_control.o \ - mpas_atmphys_driver.o \ - mpas_atmphys_driver_cloudiness.o \ - mpas_atmphys_driver_convection_deep.o \ - mpas_atmphys_driver_gwdo.o \ - mpas_atmphys_driver_lsm.o \ - mpas_atmphys_driver_microphysics.o \ - mpas_atmphys_driver_pbl.o \ - mpas_atmphys_driver_radiation_lw.o \ - mpas_atmphys_driver_radiation_sw.o \ - mpas_atmphys_driver_sfclayer.o \ - mpas_atmphys_init.o \ - mpas_atmphys_landuse.o \ - mpas_atmphys_lsm_noahinit.o \ - mpas_atmphys_manager.o \ - mpas_atmphys_rrtmg_lwinit.o \ - mpas_atmphys_rrtmg_swinit.o \ - mpas_atmphys_todynamics.o \ - mpas_atmphys_update_surface.o \ - mpas_atmphys_update.o \ + mpas_atmphys_camrad_init.o \ + mpas_atmphys_control.o \ + mpas_atmphys_driver.o \ + mpas_atmphys_driver_cloudiness.o \ + mpas_atmphys_driver_convection.o \ + mpas_atmphys_driver_gwdo.o \ + mpas_atmphys_driver_lsm.o \ + mpas_atmphys_driver_microphysics.o \ + mpas_atmphys_driver_pbl.o \ + mpas_atmphys_driver_radiation_lw.o \ + mpas_atmphys_driver_radiation_sw.o \ + mpas_atmphys_driver_sfclayer.o \ + mpas_atmphys_init.o \ + mpas_atmphys_landuse.o \ + mpas_atmphys_lsm_noahinit.o \ + mpas_atmphys_manager.o \ + mpas_atmphys_rrtmg_lwinit.o \ + mpas_atmphys_rrtmg_swinit.o \ + mpas_atmphys_todynamics.o \ + mpas_atmphys_update_surface.o \ + mpas_atmphys_update.o \ mpas_atmphys_vars.o -OBJS_dyn = mpas_atmphys_interface_nhyd.o +OBJS_dyn = mpas_atmphys_interface.o all: lookup_tables core_physics_init core_physics_wrf core_dyn core_physics @@ -67,7 +67,7 @@ mpas_atmphys_control.o: \ mpas_atmphys_driver.o: \ mpas_atmphys_driver_cloudiness.o \ - mpas_atmphys_driver_convection_deep.o \ + mpas_atmphys_driver_convection.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_pbl.o \ @@ -75,7 +75,7 @@ mpas_atmphys_driver.o: \ mpas_atmphys_driver_radiation_sw.o \ mpas_atmphys_driver_sfclayer.o \ mpas_atmphys_constants.o \ - mpas_atmphys_interface_nhyd.o \ + mpas_atmphys_interface.o \ mpas_atmphys_update.o \ mpas_atmphys_vars.o @@ -83,7 +83,7 @@ mpas_atmphys_driver_cloudiness.o: \ mpas_atmphys_constants.o \ mpas_atmphys_vars.o -mpas_atmphys_driver_convection_deep.o: \ +mpas_atmphys_driver_convection.o: \ mpas_atmphys_constants.o \ mpas_atmphys_utilities.o \ mpas_atmphys_vars.o \ @@ -103,7 +103,7 @@ mpas_atmphys_driver_lsm.o: \ mpas_atmphys_driver_microphysics.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_interface_nhyd.o \ + mpas_atmphys_interface.o \ mpas_atmphys_vars.o \ ./physics_wrf/module_mp_kessler.o \ ./physics_wrf/module_mp_wsm6.o @@ -138,7 +138,7 @@ mpas_atmphys_driver_sfclayer.o: \ ./physics_wrf/module_sf_sfclay.o mpas_atmphys_init.o: \ - mpas_atmphys_driver_convection_deep.o \ + mpas_atmphys_driver_convection.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_microphysics.o \ mpas_atmphys_driver_radiation_lw.o \ @@ -147,7 +147,7 @@ mpas_atmphys_init.o: \ mpas_atmphys_landuse.o \ mpas_atmphys_o3climatology.o -mpas_atmphys_interface_nhyd.o: \ +mpas_atmphys_interface.o: \ mpas_atmphys_constants.o \ mpas_atmphys_vars.o @@ -193,12 +193,15 @@ mpas_atmphys_update_surface.o: \ mpas_atmphys_vars.o mpas_atmphys_update.o: \ - mpas_atmphys_driver_convection_deep.o \ + mpas_atmphys_driver_convection.o \ mpas_atmphys_vars.o clean: $(RM) *.o *.mod *.f90 libphys.a ( cd physics_wrf; make clean ) + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: $(RM) $@ $*.mod diff --git a/src/core_atmosphere/physics/checkout_data_files.sh b/src/core_atmosphere/physics/checkout_data_files.sh index 4e8cfc8bee..14660e67e4 100755 --- a/src/core_atmosphere/physics/checkout_data_files.sh +++ b/src/core_atmosphere/physics/checkout_data_files.sh @@ -19,7 +19,7 @@ # ################################################################################ -mpas_vers="2.1" +mpas_vers="3.0" if [ -s physics_wrf/files/COMPATIBILITY ]; then diff --git a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F index bb1ef90c41..36a070d746 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F @@ -17,7 +17,7 @@ module mpas_atmphys_camrad_init use mpas_kind_types use mpas_grid_types - use mpas_atmphys_constants,only: cp,degrad,ep_2,g,R_d,R_v,stbolt + use mpas_atmphys_constants,only: cp,degrad,ep_2,gravity,R_d,R_v,stbolt use mpas_atmphys_utilities !wrf physics: @@ -53,6 +53,11 @@ module mpas_atmphys_camrad_init !> * moved the arrays pin and ozmixm from the mesh structure to the atm_input structure in !> subroutine oznini. !> Laura D. Fowler (birch.ucar.edu) / 2013-07-08. +!> * Replaced the variable g (that originally pointed to gravity) with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * Modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. + !local parameters: integer,parameter:: latsiz = 64 @@ -60,18 +65,21 @@ module mpas_atmphys_camrad_init contains + !================================================================================================== - subroutine camradinit(dminfo,mesh,atm_input,diag,state_1,state_2) + subroutine camradinit(dminfo,mesh,atm_input,diag,state,time_lev) !================================================================================================== !input arguments: type(dm_info),intent(in):: dminfo - type(mesh_type),intent(in):: mesh - type(diag_type),intent(in):: diag + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: diag + + integer,intent(in):: time_lev !inout arguments: - type(atm_input_type),intent(inout):: atm_input - type(state_type),intent(inout):: state_1,state_2 + type(mpas_pool_type),intent(inout):: atm_input + type(mpas_pool_type),intent(inout):: state !local variables: real(r8):: pstd @@ -126,20 +134,20 @@ subroutine camradinit(dminfo,mesh,atm_input,diag,state_1,state_2) epsqs = EP_2 !initialization of some constants: - call radini(dminfo,g,cp,ep_2,stbolt,pstd*10.0) - write(0,*) ' end subroutine radini' + call radini(dminfo,gravity,cp,ep_2,stbolt,pstd*10.0) +! write(0,*) ' end subroutine radini' !initialization of saturation vapor pressures: call esinti(epsqs,latvap,latice,rh2o,cpair,tmelt) - write(0,*) ' end subroutine esinti' +! write(0,*) ' end subroutine esinti' !initialization of ozone mixing ratios: call oznini(mesh,atm_input) - write(0,*) ' end subroutine oznini' +! write(0,*) ' end subroutine oznini' !initialization of aerosol concentrations: - call aerosol_init(dminfo,mesh,diag,state_1,state_2) - write(0,*) ' end subroutine aerosol_init' + call aerosol_init(dminfo,mesh,diag,state,time_lev) +! write(0,*) ' end subroutine aerosol_init' end subroutine camradinit @@ -386,7 +394,7 @@ subroutine radaeini(dminfo,pstdx,mwdryx,mwco2x) end subroutine radaeini !================================================================================================== - subroutine aerosol_init(dminfo,mesh,diag,state_1,state_2) + subroutine aerosol_init(dminfo,mesh,diag,state,time_lev) !================================================================================================== !This subroutine assumes a uniform aerosol distribution in both time and space. It should be @@ -394,22 +402,30 @@ subroutine aerosol_init(dminfo,mesh,diag,state_1,state_2) !input arguments:! type(dm_info),intent(in) :: dminfo - type(mesh_type),intent(in):: mesh - type(diag_type),intent(in):: diag + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: diag + + integer,intent(in):: time_lev !inout arguments: - type(state_type),intent(inout):: state_1,state_2 + type(mpas_pool_type),intent(inout):: state + +!local pointers: + integer, pointer:: nAerLevels,nCells,nCellsSolve,nVertLevels + real(kind=RKIND),dimension(:),pointer:: m_psp,m_psn + real(kind=RKIND),dimension(:,:),pointer:: m_hybi + real(kind=RKIND),dimension(:,:),pointer:: pressure_b + real(kind=RKIND),dimension(:,:,:),pointer:: aerosolcn,aerosolcp + + integer,pointer:: idxSUL_l,idxSSLT_l,idxDUSTfirst_l,idxOCPHO_l,idxCARBONfirst_l, & + idxBCPHO_l,idxOCPHI_l,idxBCPHI_l,idxBG_l,idxVOLC_l !local variables: integer:: max_mxaerl integer,dimension(:),allocatable:: mxaerl_local - integer:: iCell,k,kk,nAerLevels,nCells,nCellsSolve,nVertLevels + integer:: iCell,k,kk real(kind=RKIND):: psurf - real(kind=RKIND),dimension(:),pointer:: m_psp,m_psn - real(kind=RKIND),dimension(:,:),pointer:: m_hybi - real(kind=RKIND),dimension(:,:),pointer:: pressure_b - real(kind=RKIND),dimension(:,:,:),pointer:: aerosolcn,aerosolcp real(kind=RKIND),dimension(29) :: hybi data hybi/0, 0.0065700002014637, 0.0138600002974272, 0.023089999333024 , & @@ -425,19 +441,18 @@ subroutine aerosol_init(dminfo,mesh,diag,state_1,state_2) !-------------------------------------------------------------------------------------------------- !initialization: - nCells = mesh % nCells - nCellsSolve = mesh % nCellsSolve - nAerLevels = mesh % nAerLevels - nVertLevels = mesh % nVertLevels - m_hybi => mesh % m_hybi % array - - pressure_b => diag % pressure_base % array + call mpas_pool_get_dimension(mesh,'nCells',nCells) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nAerLevels',nAerLevels) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) - m_psp => state_1 % m_ps % array - m_psn => state_2 % m_ps % array + call mpas_pool_get_array(mesh,'m_hybi',m_hybi) + call mpas_pool_get_array(diag,'pressure_base',pressure_b) - aerosolcp => state_1 % aerosols % array - aerosolcn => state_2 % aerosols % array + call mpas_pool_get_array(state,'m_ps',m_psp,1) + call mpas_pool_get_array(state,'m_ps',m_psn,2) + call mpas_pool_get_array(state,'aerosols',aerosolcp,1) + call mpas_pool_get_array(state,'aerosols',aerosolcn,2) !initialization of aerosol levels: do k = 1, nAerLevels @@ -476,17 +491,28 @@ subroutine aerosol_init(dminfo,mesh,diag,state_1,state_2) ixcldice = 3 !initialize indices for aerosol species: - idxSUL = state_1 % index_sul - idxSSLT = state_1 % index_sslt - idxDUSTfirst = state_1 % index_dust1 - idxOCPHO = state_1 % index_ocpho - idxCARBONFIRST = state_1 % index_ocpho - idxBCPHO = state_1 % index_bcpho - idxOCPHI = state_1 % index_ocphi - idxBCPHI = state_1 % index_bcphi - idxBG = state_1 % index_bg - idxVOLC = state_1 % index_volc - + call mpas_pool_get_dimension(state,'index_sul' ,idxSUL_l ) + call mpas_pool_get_dimension(state,'index_sslt' ,idxSSLT_l ) + call mpas_pool_get_dimension(state,'index_dust1',idxDUSTfirst_l ) + call mpas_pool_get_dimension(state,'index_ocpho',idxOCPHO_l ) + call mpas_pool_get_dimension(state,'index_ocpho',idxCARBONfirst_l) + call mpas_pool_get_dimension(state,'index_bcpho',idxBCPHO_l ) + call mpas_pool_get_dimension(state,'index_ocphi',idxOCPHI_l ) + call mpas_pool_get_dimension(state,'index_bcphi',idxBCPHI_l ) + call mpas_pool_get_dimension(state,'index_bg' ,idxBG_l ) + call mpas_pool_get_dimension(state,'index_volc' ,idxVOLC_l ) + + idxSUL = idxSUL_l + idxSSLT = idxSSLT_l + idxDUSTfirst = idxDUSTfirst_l + idxOCPHO = idxOCPHO_l + idxCARBONfirst = idxCARBONfirst_l + idxBCPHO = idxBCPHO_l + idxOCPHI = idxOCPHI_l + idxBCPHI = idxBCPHI_l + idxBG = idxBG_l + idxVOLC = idxVOLC_l + write(0,*) ' idxSUL =',idxSUL write(0,*) ' idxSSLT =',idxSSLT write(0,*) ' idxDUSTfirst =',idxDUSTfirst @@ -712,7 +738,7 @@ subroutine aer_optics_initialize(dminfo) enddo enddo - write(0,*) ' end subroutine aer_optics_initialize:' +! write(0,*) ' end subroutine aer_optics_initialize:' end subroutine aer_optics_initialize @@ -724,10 +750,16 @@ subroutine oznini(mesh,atm_input) !with monthly climatology varying ozone distribution. !input arguments: - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh !inout arguments: - type(atm_input_type),intent(inout):: atm_input + type(mpas_pool_type),intent(inout):: atm_input + +!local pointers: + integer,pointer:: nCells,num_months,levsiz + real(kind=RKIND),dimension(:),pointer:: latCell,lonCell + real(kind=RKIND),dimension(:),pointer:: pin + real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm !local variables: integer,parameter:: pin_unit = 27 @@ -736,12 +768,8 @@ subroutine oznini(mesh,atm_input) integer,parameter:: open_ok = 0 integer:: i,i1,i2,istat,k,j,m - integer:: iCell,nCells,num_months,levsiz + integer:: iCell - real(kind=RKIND),dimension(:),pointer:: latCell,lonCell - real(kind=RKIND),dimension(:),pointer:: pin - real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm - real(kind=RKIND):: lat,lon,dlat,dlatCell real(kind=RKIND),dimension(latsiz):: lat_ozone !real(Kind=RKIND),dimension(lonsiz,levsiz,latsiz,num_months):: ozmixin @@ -749,13 +777,14 @@ subroutine oznini(mesh,atm_input) !-------------------------------------------------------------------------------------------------- - nCells = mesh % nCells - num_months = mesh % nMonths - levsiz = mesh % nOznLevels - latCell => mesh % latCell % array - lonCell => mesh % lonCell % array - pin => atm_input % pin % array - ozmixm => atm_input % ozmixm % array + call mpas_pool_get_dimension(mesh,'nCells',nCells) + call mpas_pool_get_dimension(mesh,'nMonths',num_months) + call mpas_pool_get_dimension(mesh,'nOznLevels',levsiz) + + call mpas_pool_get_array(mesh,'latCell',latCell) + call mpas_pool_get_array(mesh,'lonCell',lonCell) + call mpas_pool_get_array(atm_input,'pin',pin) + call mpas_pool_get_array(atm_input,'ozmixm',ozmixm) !-- read in ozone pressure data: open(pin_unit,file='OZONE_PLEV.TBL',action='READ',status='OLD',iostat=istat) diff --git a/src/core_atmosphere/physics/mpas_atmphys_constants.F b/src/core_atmosphere/physics/mpas_atmphys_constants.F index 8c90b3d8a9..3f8a33b8a7 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_constants.F +++ b/src/core_atmosphere/physics/mpas_atmphys_constants.F @@ -5,10 +5,10 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! -!============================================================================================= +!================================================================================================== module mpas_atmphys_constants - use mpas_kind_types, only : RKIND - use mpas_constants, only : pii, cp, R_d => rgas, g => gravity + use mpas_kind_types + use mpas_constants, only : pii, cp, gravity, R_d => rgas implicit none public @@ -20,6 +20,13 @@ module mpas_atmphys_constants !>\date 2013-05-01. !> !>\details +!> +!> add-ons and modifications to sourcecode: +!> ---------------------------------------- +!> * Replaced the variable g (that originally pointed to gravity) with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * Removed the constraint of only using RKIND from mpas_kind_types. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. !================================================================================================== @@ -33,7 +40,7 @@ module mpas_atmphys_constants real(kind=RKIND),parameter:: ep_1 = R_v/R_d-1. real(kind=RKIND),parameter:: ep_2 = R_d/R_v real(kind=RKIND),parameter:: cpv = 4.*R_v - real(kind=RKIND),parameter:: rdg = R_d/g + real(kind=RKIND),parameter:: rdg = R_d/gravity real(kind=RKIND),parameter:: rcp = R_d/cp real(kind=RKIND),parameter:: rcv = R_d/(cp-R_d) diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index 5f56484069..1bc1ad612b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -7,7 +7,7 @@ ! !================================================================================================== module mpas_atmphys_control - use mpas_configure + use mpas_kind_types use mpas_grid_types use mpas_atmphys_utilities @@ -15,7 +15,6 @@ module mpas_atmphys_control implicit none private public:: physics_namelist_check, & - physics_idealized_init, & physics_registry_init logical,public:: moist_physics @@ -39,18 +38,56 @@ module mpas_atmphys_control !> * removed the namelist option config_eddy_scheme and associated sourcecode. !> * removed the namelist option config_conv_shallow_scheme and associated sourcecode. !> * removed controls to the updated Kain-Fritsch convection scheme. -!> Laura D. Fowler (birch.ucar.edu) / 2013-05-29. +!> Laura D. Fowler (laura@ucar.edu) / 2013-05-29. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * removed subroutine physics_idealized_init, also available in mpas_init_atm_cases.F in +!> core_init_atmosphere. +!> Laura D. Fowler (laura@ucar.edu) / 2014-08-11. +!> * renamed config_conv_deep_scheme to config_convection_scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. + contains + !================================================================================================== - subroutine physics_namelist_check + subroutine physics_namelist_check(mesh,configs) !================================================================================================== - write(0,*) - write(0,*) '--- enter subroutine physics_namelist_check:' +!input arguments: + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: config_microp_scheme, & + config_convection_scheme, & + config_lsm_scheme, & + config_pbl_scheme, & + config_gwdo_scheme, & + config_radt_cld_scheme, & + config_radt_lw_scheme, & + config_radt_sw_scheme, & + config_sfclayer_scheme + +!-------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) + call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,config_pbl_scheme ) + call mpas_pool_get_config(configs,'config_gwdo_scheme' ,config_gwdo_scheme ) + call mpas_pool_get_config(configs,'config_radt_cld_scheme' ,config_radt_cld_scheme ) + call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) + call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) + +! write(0,*) +! write(0,*) '--- enter subroutine physics_namelist_check:' write(0,*) ' config_microp_scheme = ', trim(config_microp_scheme) - write(0,*) ' config_conv_deep_scheme = ', trim(config_conv_deep_scheme) + write(0,*) ' config_convection_scheme = ', trim(config_convection_scheme) write(0,*) ' config_lsm_scheme = ', trim(config_lsm_scheme) write(0,*) ' config_pbl_scheme = ', trim(config_pbl_scheme) write(0,*) ' config_gwdo_scheme = ', trim(config_gwdo_scheme) @@ -70,13 +107,13 @@ subroutine physics_namelist_check endif -!deep convection scheme: - if(.not. (config_conv_deep_scheme .eq. 'off' .or. & - config_conv_deep_scheme .eq. 'kain_fritsch' .or. & - config_conv_deep_scheme .eq. 'tiedtke' )) then +!convection scheme: + if(.not. (config_convection_scheme .eq. 'off' .or. & + config_convection_scheme .eq. 'kain_fritsch' .or. & + config_convection_scheme .eq. 'tiedtke' )) then - write(mpas_err_message,'(A,A10)') 'illegal value for config_deep_conv_scheme: ', & - trim(config_conv_deep_scheme) + write(mpas_err_message,'(A,A10)') 'illegal value for config_convection_scheme: ', & + trim(config_convection_scheme) call physics_error_fatal(mpas_err_message) endif @@ -182,32 +219,48 @@ subroutine physics_namelist_check !checks if any physics process is called. if not, return: moist_physics = .true. - if(config_microp_scheme .eq. 'off' .and. & - config_conv_deep_scheme .eq. 'off' .and. & - config_lsm_scheme .eq. 'off' .and. & - config_pbl_scheme .eq. 'off' .and. & - config_radt_lw_scheme .eq. 'off' .and. & - config_radt_sw_scheme .eq. 'off' .and. & - config_sfclayer_scheme .eq. 'off') moist_physics = .false. + if(config_microp_scheme .eq. 'off' .and. & + config_convection_scheme .eq. 'off' .and. & + config_lsm_scheme .eq. 'off' .and. & + config_pbl_scheme .eq. 'off' .and. & + config_radt_lw_scheme .eq. 'off' .and. & + config_radt_sw_scheme .eq. 'off' .and. & + config_sfclayer_scheme .eq. 'off') moist_physics = .false. - write(0,*) '--- end subroutine physics_namelist_check:' +! write(0,*) '--- end subroutine physics_namelist_check:' end subroutine physics_namelist_check !================================================================================================== - subroutine physics_registry_init(config_do_restart,mesh,sfc_input) + subroutine physics_registry_init(mesh,configs,sfc_input) !================================================================================================== -!input and output arguments: - logical,intent(in):: config_do_restart - type(mesh_type),intent(in):: mesh - type(sfc_input_type),intent(inout):: sfc_input +!input and inout arguments: + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + logical,pointer:: config_do_restart + character(len=StrKIND),pointer:: config_lsm_scheme + integer,pointer:: nCells + integer,dimension(:),pointer:: landmask + + real(kind=RKIND),dimension(:,:),pointer:: dzs !local variables: integer:: iCell - + !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + call mpas_pool_get_config(configs,'config_lsm_scheme',config_lsm_scheme) + + call mpas_pool_get_dimension(mesh,'nCells',nCells) + + call mpas_pool_get_array(sfc_input,'landmask',landmask) + call mpas_pool_get_array(sfc_input,'dzs' , dzs ) + !initialization of input variables, if needed: if(.not. config_do_restart) then @@ -216,12 +269,12 @@ subroutine physics_registry_init(config_do_restart,mesh,sfc_input) case("noah") !initialize the thickness of the soil layers for the Noah scheme: - do iCell = 1, mesh % nCells - if(sfc_input % landmask % array(iCell) == 1) then - sfc_input % dzs % array(1,iCell) = 0.10 - sfc_input % dzs % array(2,iCell) = 0.30 - sfc_input % dzs % array(3,iCell) = 0.60 - sfc_input % dzs % array(4,iCell) = 1.00 + do iCell = 1, nCells + if(landmask(iCell) == 1) then + dzs(1,iCell) = 0.10_RKIND + dzs(2,iCell) = 0.30_RKIND + dzs(3,iCell) = 0.60_RKIND + dzs(4,iCell) = 1.00_RKIND endif enddo @@ -233,62 +286,6 @@ subroutine physics_registry_init(config_do_restart,mesh,sfc_input) end subroutine physics_registry_init -!================================================================================================== - subroutine physics_idealized_init(mesh,sfc_input) -!================================================================================================== - -!input and output arguments: - type(mesh_type),intent(in):: mesh - type(sfc_input_type),intent(inout):: sfc_input - -!local variables: - integer:: iCell,iMonth,iSoil - -!-------------------------------------------------------------------------------------------------- - -!initialization of surface input variables that are not needed if we run the current set of -!idealized test cases: - - do iCell = 1, mesh % nCells - !terrain,soil type, and vegetation: - sfc_input % ter % array(iCell) = 0. - sfc_input % xice % array(iCell) = 0. - sfc_input % landmask % array(iCell) = 0 - sfc_input % ivgtyp % array(iCell) = 0 - sfc_input % isltyp % array(iCell) = 0 - sfc_input % shdmin % array(iCell) = 0. - sfc_input % shdmax % array(iCell) = 0. - sfc_input % vegfra % array(iCell) = 0. - - !snow coverage: - sfc_input % snow % array(iCell) = 0. - sfc_input % snowc % array(iCell) = 0. - sfc_input % snoalb % array(iCell) = 0.08 - - !surface and sea-surface temperatures: - sfc_input % skintemp % array(iCell) = 288.0 - sfc_input % sst % array(iCell) = 288.0 - - !soil layers: - sfc_input % tmn % array(iCell) = 288.0 - do iSoil = 1, mesh % nSoilLevels - sfc_input % tslb % array(iSoil,iCell) = 288.0 - sfc_input % smcrel % array(iSoil,iCell) = 0.0 - sfc_input % sh2o % array(iSoil,iCell) = 0.0 - sfc_input % smois % array(iSoil,iCell) = 0.0 - sfc_input % dzs % array(iSoil,iCell) = 0.0 - enddo - - !monthly climatological surface albedo and greeness fraction: - do iMonth = 1, mesh % nMonths - sfc_input % albedo12m % array(iMonth,iCell) = 0.08 - sfc_input % greenfrac % array(iMonth,iCell) = 0. - enddo - - enddo - - end subroutine physics_idealized_init - !================================================================================================== end module mpas_atmphys_control !================================================================================================== diff --git a/src/core_atmosphere/physics/mpas_atmphys_date_time.F b/src/core_atmosphere/physics/mpas_atmphys_date_time.F index da284983e4..926b72c04e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_date_time.F +++ b/src/core_atmosphere/physics/mpas_atmphys_date_time.F @@ -36,7 +36,7 @@ module mpas_atmphys_date_time !> StrKIND to 2 to input correctly the reference date to subroutine get_julgmt_date. !> * in subroutines get_julgmt_date and split_date_char, changed the declaration of date_str !> from StrKIND to *. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-10-18. +!> Laura D. Fowler (laura@ucar.edu) / 2013-10-18. contains diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index b8e9a260a6..27ede07757 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -7,11 +7,11 @@ ! !================================================================================================== module mpas_atmphys_driver - use mpas_configure + use mpas_kind_types use mpas_grid_types use mpas_atmphys_driver_cloudiness - use mpas_atmphys_driver_convection_deep + use mpas_atmphys_driver_convection use mpas_atmphys_driver_gwdo use mpas_atmphys_driver_lsm use mpas_atmphys_driver_pbl @@ -19,7 +19,7 @@ module mpas_atmphys_driver use mpas_atmphys_driver_radiation_sw use mpas_atmphys_driver_sfclayer use mpas_atmphys_constants - use mpas_atmphys_interface_nhyd + use mpas_atmphys_interface use mpas_atmphys_update use mpas_atmphys_vars, only: l_camlw,l_conv,l_radtlw,l_radtsw @@ -40,7 +40,7 @@ module mpas_atmphys_driver !> ------------------------------------------ !> allocate_forall_physics : allocate local arrays defining atmospheric soundings (pressure,..) !> allocate_cloudiness : allocate all local arrays used in driver_cloudiness. -!> allocate_convection_deep : allocate all local arrays used in driver_convection_deep. +!> allocate_convection : allocate all local arrays used in driver_convection. !> allocate_gwdo : allocate all local arrays used in driver_gwdo. !> allocate_lsm : allocate all local arrays used in driver_lsm. !> allocate_pbl : allocate all local arrays used in driver_pbl. @@ -50,7 +50,7 @@ module mpas_atmphys_driver !> !> deallocate_forall_physics : deallocate local arrays defining atmospheric soundings. !> deallocate_cloudiness : dedeallocate all local arrays used in driver_cloudiness. -!> deallocate_convection_deep : deallocate all local arrays used in driver_convection_deep. +!> deallocate_convection : deallocate all local arrays used in driver_convection. !> deallocate_gwdo : deallocate all local arrays used in driver_gwdo. !> deallocate_lsm : deallocate all local arrays used in driver_lsm. !> deallocate_pbl : deallocate all local arrays used in driver_pbl. @@ -60,7 +60,7 @@ module mpas_atmphys_driver !> !> MPAS_to_physics : !> driver_cloudiness : driver for parameterization of fractional cloudiness. -!> driver_convection_deep : driver for parameterization of convection. +!> driver_convection : driver for parameterization of convection. !> driver_gwdo : driver for parameterization of gravity wave drag over orography. !> driver_lsm : driver for land-surface scheme. !> driver_pbl : driver for planetary boundary layer scheme. @@ -79,11 +79,16 @@ module mpas_atmphys_driver !> * removed the namelist option config_conv_shallow_scheme and associated sourcecode. !> Laura D. Fowler (birch.ucar.edu) / 2013-05-29. !> * added block%atm_input in calls to subroutines driver_radiation_lw amd driver_radiation_lw. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-03. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-03. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * renamed config_conv_deep_scheme to config_convection_scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. contains + !================================================================================================== subroutine physics_driver(domain,itimestep,xtime_s) !================================================================================================== @@ -95,53 +100,94 @@ subroutine physics_driver(domain,itimestep,xtime_s) !inout arguments: type(domain_type),intent(inout):: domain +!local pointers: + type(mpas_pool_type),pointer:: configs, & + mesh, & + state, & + diag, & + diag_physics, & + tend_physics, & + atm_input, & + sfc_input + + real(kind=RKIND),pointer:: config_bucket_radt + + character(len=StrKIND),pointer:: config_bucket_update, & + config_convection_scheme, & + config_gwdo_scheme, & + config_lsm_scheme, & + config_pbl_scheme, & + config_radt_lw_scheme, & + config_radt_sw_scheme, & + config_sfclayer_scheme + !local variables: type(block_type),pointer:: block + integer:: time_lev + !================================================================================================== - if(config_conv_deep_scheme .ne. 'off' .or. & - config_lsm_scheme .ne. 'off' .or. & - config_pbl_scheme .ne. 'off' .or. & - config_radt_lw_scheme .ne. 'off' .or. & - config_radt_sw_scheme .ne. 'off' .or. & - config_sfclayer_scheme .ne. 'off') then + call mpas_pool_get_config(domain%configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(domain%configs,'config_gwdo_scheme' ,config_gwdo_scheme ) + call mpas_pool_get_config(domain%configs,'config_lsm_scheme' ,config_lsm_scheme ) + call mpas_pool_get_config(domain%configs,'config_pbl_scheme' ,config_pbl_scheme ) + call mpas_pool_get_config(domain%configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) + call mpas_pool_get_config(domain%configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + call mpas_pool_get_config(domain%configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) + call mpas_pool_get_config(domain%configs,'config_bucket_radt' ,config_bucket_radt ) + call mpas_pool_get_config(domain%configs,'config_bucket_update' ,config_bucket_update ) + + if(config_convection_scheme .ne. 'off' .or. & + config_lsm_scheme .ne. 'off' .or. & + config_pbl_scheme .ne. 'off' .or. & + config_radt_lw_scheme .ne. 'off' .or. & + config_radt_sw_scheme .ne. 'off' .or. & + config_sfclayer_scheme .ne. 'off') then block => domain % blocklist do while(associated(block)) + call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) + call mpas_pool_get_subpool(block%structs,'state' ,state ) + call mpas_pool_get_subpool(block%structs,'diag' ,diag ) + call mpas_pool_get_subpool(block%structs,'diag_physics',diag_physics) + call mpas_pool_get_subpool(block%structs,'atm_input' ,atm_input ) + call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) + call mpas_pool_get_subpool(block%structs,'tend_physics',tend_physics) + !allocate arrays shared by all physics parameterizations: call allocate_forall_physics !physics prep step: - call MPAS_to_physics(block%mesh,block%state%time_levs(1)%state,block%diag, & - block%diag_physics) + time_lev = 1 + call MPAS_to_physics(mesh,state,time_lev,diag,diag_physics) !call to cloud scheme: if(l_radtlw .or. l_radtsw) then call allocate_cloudiness - call driver_cloudiness(block%diag_physics) + call driver_cloudiness(diag_physics) endif !call to short wave radiation scheme: if(l_radtsw) then + time_lev = 1 call allocate_radiation_sw(xtime_s) - call driver_radiation_sw(itimestep,block%mesh,block%state%time_levs(1)%state, & - block%diag_physics,block%atm_input,block%sfc_input, & - block%tend_physics,xtime_s) + call driver_radiation_sw(itimestep,block%configs,mesh,state,time_lev,diag_physics, & + atm_input,sfc_input,tend_physics,xtime_s) endif !call to long wave radiation scheme: if(l_radtlw) then + time_lev = 1 call allocate_radiation_lw(xtime_s) - call driver_radiation_lw(xtime_s,block%mesh,block%state%time_levs(1)%state, & - block%diag_physics,block%atm_input,block%sfc_input, & - block%tend_physics) + call driver_radiation_lw(xtime_s,block%configs,mesh,state,time_lev,diag_physics, & + atm_input,sfc_input,tend_physics) endif !call to accumulate long- and short-wave diagnostics if needed: if(config_bucket_update /= 'none' .and. config_bucket_radt .gt. 0._RKIND) & - call update_radiation_diagnostics(config_bucket_radt,block%mesh,block%diag_physics) + call update_radiation_diagnostics(block%configs,mesh,diag_physics) !deallocate all radiation arrays: if(config_radt_sw_scheme.ne.'off' .or. config_radt_lw_scheme.ne.'off') & @@ -152,42 +198,40 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to surface-layer scheme: if(config_sfclayer_scheme .ne. 'off') then call allocate_sfclayer - call driver_sfclayer(block%mesh,block%diag_physics,block%sfc_input) + call driver_sfclayer(mesh,diag_physics,sfc_input) call deallocate_sfclayer endif !call to land-surface scheme: if(config_lsm_scheme .ne. 'off') then call allocate_lsm - call driver_lsm(itimestep,block%mesh,block%diag_physics,block%sfc_input) + call driver_lsm(itimestep,block%configs,mesh,diag_physics,sfc_input) call deallocate_lsm endif !call to pbl schemes: if(config_pbl_scheme .ne. 'off' .and. config_sfclayer_scheme .ne. 'off') then call allocate_pbl - call driver_pbl(block%sfc_input,block%diag_physics,block%tend_physics) + call driver_pbl(sfc_input,diag_physics,tend_physics) call deallocate_pbl endif !call to gravity wave drag over orography scheme: if(config_gwdo_scheme .ne. 'off') then call allocate_gwdo - call driver_gwdo(itimestep,block%mesh,block%sfc_input,block%diag_physics, & - block%tend_physics) + call driver_gwdo(itimestep,mesh,sfc_input,diag_physics,tend_physics) call deallocate_gwdo endif !call to convection scheme: - call update_convection_step1(block%mesh,block%diag_physics,block%tend_physics) + call update_convection_step1(mesh,diag_physics,tend_physics) if(l_conv) then - call allocate_convection_deep - call driver_convection_deep(itimestep,block%mesh,block%sfc_input,block%diag_physics, & - block%tend_physics) - call deallocate_convection_deep + call allocate_convection + call driver_convection(itimestep,mesh,sfc_input,diag_physics,tend_physics) + call deallocate_convection endif !update diagnostics: - call update_convection_step2(config_bucket_rainc,block%mesh,block%diag_physics) + call update_convection_step2(block%configs,mesh,diag_physics) !deallocate arrays shared by all physics parameterizations: call deallocate_forall_physics @@ -196,9 +240,9 @@ subroutine physics_driver(domain,itimestep,xtime_s) end do endif - write(0,*) - write(0,*) '--- end physics_driver:' - write(0,*) +! write(0,*) +! write(0,*) '--- end physics_driver:' +! write(0,*) end subroutine physics_driver diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F index 900e543c8c..d437798021 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F @@ -7,6 +7,7 @@ ! !================================================================================================== module mpas_atmphys_driver_cloudiness + use mpas_kind_types use mpas_grid_types use mpas_atmphys_constants, only: ep_2 @@ -37,13 +38,17 @@ module mpas_atmphys_driver_cloudiness !> calc_cldincidence : calculates the cloud fraction as 0 or 1, depending on cloud condensates. !> calc_cldfraction : calculates the cloud fraction as a function of the relative humidity. !> -!> comments: -!> The subroutine calc_cldfraction has not been testted in MPAS. The default is to use subroutine -!> calc_cldincidence. +!> add-ons and modifications to sourcecode: +!> ---------------------------------------- +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. contains + !================================================================================================== subroutine allocate_cloudiness !================================================================================================== @@ -65,14 +70,14 @@ subroutine cloudiness_from_MPAS(diag_physics) !================================================================================================== !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics !-------------------------------------------------------------------------------------------------- do j = jts,jte do k = kts,kte do i = its,ite - cldfrac_p(i,k,j) = 0. + cldfrac_p(i,k,j) = 0._RKIND enddo enddo enddo @@ -84,14 +89,19 @@ subroutine cloudiness_to_MPAS(diag_physics) !================================================================================================== !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + real(kind=RKIND),dimension(:,:),pointer:: cldfrac !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'cldfrac',cldfrac) + do j = jts,jte do k = kts,kte do i = its,ite - diag_physics % cldfrac % array(k,i) = cldfrac_p(i,k,j) + cldfrac(k,i) = cldfrac_p(i,k,j) enddo enddo enddo @@ -103,11 +113,11 @@ subroutine driver_cloudiness(diag_physics) !================================================================================================== !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine driver_cloudiness:' +! write(0,*) +! write(0,*) '--- enter subroutine driver_cloudiness:' !copy MPAS arrays to local arrays: call cloudiness_from_MPAS(diag_physics) @@ -116,16 +126,16 @@ subroutine driver_cloudiness(diag_physics) case("cld_incidence") !calculate the incidence of clouds: - write(0,*) '--- enter subroutine calc_cldincidence:' +! write(0,*) '--- enter subroutine calc_cldincidence:' call calc_cldincidence(cldfrac_p,qc_p,qi_p,f_qc,f_qi) - write(0,*) '--- exit subroutine calc_cldincidence' +! write(0,*) '--- exit subroutine calc_cldincidence' case("cld_fraction") !calculate the cloud fraction based on the relative humidity: - write(0,*) '--- enter subroutine calc_cldfraction:' +! write(0,*) '--- enter subroutine calc_cldfraction:' call calc_cldfraction(cldfrac_p,t_p,pres_p,qv_p,qc_p,qi_p,qs_p) - write(0,*) '--- exit subroutine calc_cldfraction' +! write(0,*) '--- exit subroutine calc_cldfraction' case default @@ -134,7 +144,7 @@ subroutine driver_cloudiness(diag_physics) !copy local arrays to MPAS grid: call cloudiness_to_MPAS(diag_physics) - write(0,*) '--- exit subroutine driver_cloudiness' +! write(0,*) '--- exit subroutine driver_cloudiness' end subroutine driver_cloudiness diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_convection_deep.F b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F similarity index 53% rename from src/core_atmosphere/physics/mpas_atmphys_driver_convection_deep.F rename to src/core_atmosphere/physics/mpas_atmphys_driver_convection.F index 8dcd65c102..97b191ca6c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_convection_deep.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F @@ -6,7 +6,8 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! !================================================================================================== - module mpas_atmphys_driver_convection_deep + module mpas_atmphys_driver_convection + use mpas_kind_types use mpas_grid_types use mpas_atmphys_constants @@ -19,11 +20,11 @@ module mpas_atmphys_driver_convection_deep implicit none private - public:: allocate_convection_deep, & - deallocate_convection_deep, & - init_convection_deep, & - driver_convection_deep, & - update_convection_step1, & + public:: allocate_convection, & + deallocate_convection, & + init_convection, & + driver_convection, & + update_convection_step1, & update_convection_step2 integer, private:: i,k,j @@ -35,19 +36,19 @@ module mpas_atmphys_driver_convection_deep !> !>\details !> -!> subroutines in mpas_atmphys_driver_convection_deep: -!> --------------------------------------------------- -!> allocate_convection_deep : allocate local arrays for parameterization of convection. -!> deallocate_convection_deep: deallocate local arrays for parameterization of convection. -!> init_convection_deep : initialization of individual convection scheme. -!> driver_convection_deep : main driver (called from subroutine physics_driver). -!> convection_from_MPAS : initialize local arrays. -!> convection_to_MPAS : copy local arrays to MPAS arrays. -!> update_convection_step1 : updates lifetime of deep convective clouds in Kain-Fritsch scheme. -!> update_convection_step2 : updates accumulated precipitation output from convection schemes. +!> subroutines in mpas_atmphys_driver_convection: +!> ---------------------------------------------- +!> allocate_convection : allocate local arrays for parameterization of convection. +!> deallocate_convection : deallocate local arrays for parameterization of convection. +!> init_convection : initialization of individual convection scheme. +!> driver_convection : main driver (called from subroutine physics_driver). +!> convection_from_MPAS : initialize local arrays. +!> convection_to_MPAS : copy local arrays to MPAS arrays. +!> update_convection_step1 : updates lifetime of deep convective clouds in Kain-Fritsch scheme. +!> update_convection_step2 : updates accumulated precipitation output from convection schemes. !> -!> WRF physics called from driver_convection_deep: -!> ----------------------------------------------- +!> WRF physics called from driver_convection: +!> ------------------------------------------ !> * module_cu_kfeta : Kain-Fritsch convection scheme. !> * module_cu_tiedtke : Tiedtke convection scheme. @@ -56,15 +57,28 @@ module mpas_atmphys_driver_convection_deep !> * removed the pre-processor option "do_hydrostatic_pressure" before call to the subroutines !> kf_eta_cps and tiedtke. !> * removed call to the updated Kain-Fritsch convection scheme. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-05-29. +!> Laura D. Fowler (laura@ucar.edu) / 2013-05-29. !> * added the mean distance between cell centers in the call to the Kain-Fritsch convection !> parameterization of convection. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-22. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-22. +!> * in call to subroutine kf_eta_cps, replaced the variable g (that originally pointed to +!> gravity) with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * Modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * in ./physics_wrf, updated the Tiedtke convection scheme to that in WRF version 3.6.1. The +!> call to subroutine cu_tiedtke has been updated accordingly to include the sensible heat +!> flux. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-11. + contains + !================================================================================================== - subroutine allocate_convection_deep + subroutine allocate_convection !================================================================================================== if(.not.allocated(cu_act_flag)) allocate(cu_act_flag(ims:ime,jms:jme) ) @@ -93,7 +107,7 @@ subroutine allocate_convection_deep enddo enddo - convection_select: select case(conv_deep_scheme) + convection_select: select case(convection_scheme) case ("kain_fritsch") if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) ) @@ -122,6 +136,7 @@ subroutine allocate_convection_deep enddo case ("tiedtke") + if(.not.allocated(hfx_p) ) allocate(hfx_p(ims:ime,jms:jme) ) if(.not.allocated(qfx_p) ) allocate(qfx_p(ims:ime,jms:jme) ) if(.not.allocated(xland_p) ) allocate(xland_p(ims:ime,jms:jme) ) if(.not.allocated(rqvdynten_p) ) allocate(rqvdynten_p(ims:ime,kms:kme,jms:jme) ) @@ -131,6 +146,7 @@ subroutine allocate_convection_deep do i = its,ite do j = jts,jte + hfx_p(i,j) = 0._RKIND qfx_p(i,j) = 0._RKIND xland_p(i,j) = 0._RKIND enddo @@ -151,10 +167,10 @@ subroutine allocate_convection_deep end select convection_select - end subroutine allocate_convection_deep + end subroutine allocate_convection !================================================================================================== - subroutine deallocate_convection_deep + subroutine deallocate_convection !================================================================================================== if(allocated(cu_act_flag)) deallocate(cu_act_flag) @@ -165,7 +181,7 @@ subroutine deallocate_convection_deep if(allocated(pratec_p) ) deallocate(pratec_p ) if(allocated(raincv_p) ) deallocate(raincv_p ) - convection_select: select case(conv_deep_scheme) + convection_select: select case(convection_scheme) case ("kain_fritsch") if(allocated(dx_p) ) deallocate(dx_p ) @@ -178,6 +194,7 @@ subroutine deallocate_convection_deep if(allocated(rqscuten_p) ) deallocate(rqscuten_p ) case ("tiedtke") + if(allocated(hfx_p) ) deallocate(hfx_p ) if(allocated(qfx_p) ) deallocate(qfx_p ) if(allocated(xland_p) ) deallocate(xland_p ) if(allocated(rqvdynten_p) ) deallocate(rqvdynten_p ) @@ -189,40 +206,49 @@ subroutine deallocate_convection_deep end select convection_select - end subroutine deallocate_convection_deep + end subroutine deallocate_convection !================================================================================================== - subroutine init_convection_deep(config_do_restart,mesh,diag_physics) + subroutine init_convection(mesh,configs,diag_physics) !================================================================================================== !input arguments: - logical,intent(in):: config_do_restart - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + logical,pointer:: config_do_restart + integer,pointer:: nCells + real(kind=RKIND),dimension(:),pointer:: nca !local variables: integer:: iCell !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter convection_deep initialization:' +! write(0,*) +! write(0,*) '--- enter subroutine init_convection:' + + call mpas_pool_get_dimension(mesh,'nCells',nCells) + call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + call mpas_pool_get_array(diag_physics,'nca',nca) - convection_select: select case(conv_deep_scheme) + convection_select: select case(convection_scheme) case ("kain_fritsch") - write(0,*) ' enter kain-fritsch initialization:' +! write(0,*) ' enter kain-fritsch initialization:' if(.not. config_do_restart) then - do iCell = 1, mesh % nCells - diag_physics % nca % array(iCell) = -100._RKIND + do iCell = 1, nCells + nca(iCell) = -100._RKIND enddo endif call kf_lutab(svp1,svp2,svp3,svpt0) - write(0,*) ' end kain-kritsch initialization' +! write(0,*) ' end kain-kritsch initialization' case ("tiedtke") - write(0,*) ' enter tiedtke initialization:' +! write(0,*) ' enter tiedtke initialization:' ! write(mpas_err_message,'(A,A10)') & ! 'Tiedtke is being tested. Do not use right now. Thanks ' ! call physics_error_fatal(mpas_err_message) @@ -231,21 +257,21 @@ subroutine init_convection_deep(config_do_restart,mesh,diag_physics) end select convection_select - write(0,*) '--- end convection_deep initialization' +! write(0,*) '--- end subroutine init_convection' - end subroutine init_convection_deep + end subroutine init_convection !================================================================================================== - subroutine driver_convection_deep(itimestep,mesh,sfc_input,diag_physics,tend_physics) + subroutine driver_convection(itimestep,mesh,sfc_input,diag_physics,tend_physics) !================================================================================================== !input and output arguments: !--------------------------- integer,intent(in):: itimestep - type(mesh_type),intent(in):: mesh - type(sfc_input_type),intent(in):: sfc_input - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics !local variables and arrays: !--------------------------- @@ -265,8 +291,8 @@ subroutine driver_convection_deep(itimestep,mesh,sfc_input,diag_physics,tend_phy real(kind=RKIND):: min_rthcuten !================================================================================================== - write(0,*) - write(0,*) '--- enter convection_driver: dt_cu=',dt_cu +! write(0,*) +! write(0,*) '--- enter convection_driver: dt_cu=',dt_cu !initialize instantaneous precipitation, and copy convective tendencies from the dynamics to !the physics grid: @@ -285,7 +311,7 @@ subroutine driver_convection_deep(itimestep,mesh,sfc_input,diag_physics,tend_phy enddo enddo - convection_select: select case(conv_deep_scheme) + convection_select: select case(convection_scheme) case ("kain_fritsch") if(itimestep == 1) then @@ -308,7 +334,7 @@ subroutine driver_convection_deep(itimestep,mesh,sfc_input,diag_physics,tend_phy xlv0 = xlv0 , xlv1 = xlv1 , & xls0 = xls0 , xls1 = xls1 , & cp = cp , r = r_d , & - g = g , ep1 = ep_1 , & + g = gravity , ep1 = ep_1 , & ep2 = ep_2 , svp1 = svp1 , & svp2 = svp2 , svp3 = svp3 , & svpt0 = svpt0 , stepcu = n_cu , & @@ -326,26 +352,26 @@ subroutine driver_convection_deep(itimestep,mesh,sfc_input,diag_physics,tend_phy ) case("tiedtke") - write(0,*) '--- enter subroutine cu_tiedtke:' +! write(0,*) '--- enter subroutine cu_tiedtke:' call cu_tiedtke ( & - pcps = pres_hyd_p , p8w = pres2_hyd_p , & - znu = znu_hyd_p , t3d = t_p , & - dt = dt_dyn , itimestep = itimestep , & - stepcu = n_cu , raincv = raincv_p , & - pratec = pratec_p , qfx = qfx_p , & - u3d = u_p , v3d = v_p , & - w = w_p , qv3d = qv_p , & - qc3d = qc_p , qi3d = qi_p , & - pi3d = pi_p , rho3d = rho_p , & - qvften = rqvdynten_p , qvpblten = rqvdynblten_p , & - dz8w = dz_p , xland = xland_p , & - cu_act_flag = cu_act_flag , cudt = dt_cu , & - f_qv = f_qv , f_qc = f_qc , & - f_qr = f_qr , f_qi = f_qi , & - f_qs = f_qs , rthcuten = rthcuten_p , & - rqvcuten = rqvcuten_p , rqccuten = rqccuten_p , & - rqicuten = rqicuten_p , rucuten = rucuten_p , & - rvcuten = rvcuten_p , & + pcps = pres_hyd_p , p8w = pres2_hyd_p , & + znu = znu_hyd_p , t3d = t_p , & + dt = dt_dyn , itimestep = itimestep , & + stepcu = n_cu , raincv = raincv_p , & + pratec = pratec_p , hfx = hfx_p , & + qfx = qfx_p , u3d = u_p , & + v3d = v_p , w = w_p , & + qv3d = qv_p , qc3d = qc_p , & + qi3d = qi_p , pi3d = pi_p , & + rho3d = rho_p , qvften = rqvdynten_p , & + qvpblten = rqvdynblten_p , dz8w = dz_p , & + xland = xland_p , cu_act_flag = cu_act_flag , & + f_qv = f_qv , f_qc = f_qc , & + f_qr = f_qr , f_qi = f_qi , & + f_qs = f_qs , rthcuten = rthcuten_p , & + rqvcuten = rqvcuten_p , rqccuten = rqccuten_p , & + rqicuten = rqicuten_p , rucuten = rucuten_p , & + rvcuten = rvcuten_p , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & @@ -359,61 +385,94 @@ subroutine driver_convection_deep(itimestep,mesh,sfc_input,diag_physics,tend_phy !specific to convection parameterization back to the dynamics grid: call convection_to_MPAS(diag_physics,tend_physics) - write(0,*) '--- end subroutine convection_driver' +! write(0,*) '--- end subroutine convection_driver' - end subroutine driver_convection_deep + end subroutine driver_convection !================================================================================================== subroutine convection_from_MPAS(dt_dyn,mesh,sfc_input,diag_physics,tend_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(sfc_input_type),intent(in) :: sfc_input - type(diag_physics_type),intent(in):: diag_physics - type(tend_physics_type),intent(in):: tend_physics + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in) :: sfc_input + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: tend_physics real(kind=RKIND),intent(in):: dt_dyn +!local pointers: + real(kind=RKIND),dimension(:),pointer :: areaCell,dcEdge_m + real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv + real(kind=RKIND),dimension(:),pointer :: hfx,qfx,xland + real(kind=RKIND),dimension(:,:),pointer:: w0avg + real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten,rqicuten,rqrcuten,rqscuten + real(kind=RKIND),dimension(:,:),pointer:: rqvblten,rqvdynten,rucuten,rvcuten + !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine convection_from_MPAS:' +! write(0,*) +! write(0,*) '--- enter subroutine convection_from_MPAS:' + + call mpas_pool_get_array(mesh,'areaCell',areaCell) + + call mpas_pool_get_array(sfc_input,'xland',xland) + + call mpas_pool_get_array(diag_physics,'dcEdge_m' ,dcEdge_m ) + call mpas_pool_get_array(diag_physics,'nca' ,nca ) + call mpas_pool_get_array(diag_physics,'cubot' ,cubot ) + call mpas_pool_get_array(diag_physics,'cutop' ,cutop ) + call mpas_pool_get_array(diag_physics,'cuprec' ,cuprec ) + call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) + call mpas_pool_get_array(diag_physics,'w0avg' ,w0avg ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + + call mpas_pool_get_array(tend_physics,'rthcuten' ,rthcuten ) + call mpas_pool_get_array(tend_physics,'rqvcuten' ,rqvcuten ) + call mpas_pool_get_array(tend_physics,'rqccuten' ,rqccuten ) + call mpas_pool_get_array(tend_physics,'rqicuten' ,rqicuten ) + call mpas_pool_get_array(tend_physics,'rqrcuten' ,rqrcuten ) + call mpas_pool_get_array(tend_physics,'rqscuten' ,rqscuten ) + call mpas_pool_get_array(tend_physics,'rucuten' ,rucuten ) + call mpas_pool_get_array(tend_physics,'rvcuten' ,rvcuten ) + call mpas_pool_get_array(tend_physics,'rqvblten' ,rqvblten ) + call mpas_pool_get_array(tend_physics,'rqvdynten',rqvdynten) do j = jts,jte do i = its,ite - raincv_p(i,j) = diag_physics % raincv % array(i) - pratec_p(i,j) = diag_physics % cuprec % array(i) + raincv_p(i,j) = raincv(i) + pratec_p(i,j) = cuprec(i) do k = kts,kte - rthcuten_p(i,k,j) = tend_physics % rthcuten % array(k,i) - rqvcuten_p(i,k,j) = tend_physics % rqvcuten % array(k,i) - rqccuten_p(i,k,j) = tend_physics % rqccuten % array(k,i) - rqicuten_p(i,k,j) = tend_physics % rqicuten % array(k,i) + rthcuten_p(i,k,j) = rthcuten(k,i) + rqvcuten_p(i,k,j) = rqvcuten(k,i) + rqccuten_p(i,k,j) = rqccuten(k,i) + rqicuten_p(i,k,j) = rqicuten(k,i) enddo enddo enddo - convection_select: select case(conv_deep_scheme) + convection_select: select case(convection_scheme) case ("kain_fritsch") do j = jts,jte do i = its,ite !area of grid-cell: - area_p(i,j) = mesh % areaCell % array(i) - dx_p(i,j) = diag_physics % dcEdge_m % array(i) - cubot_p(i,j) = diag_physics % cubot % array(i) - cutop_p(i,j) = diag_physics % cutop % array(i) + area_p(i,j) = areaCell(i) + dx_p(i,j) = dcEdge_m(i) + cubot_p(i,j) = cubot(i) + cutop_p(i,j) = cutop(i) do k = kts,kte - rqrcuten_p(i,k,j) = tend_physics % rqrcuten % array(k,i) - rqscuten_p(i,k,j) = tend_physics % rqscuten % array(k,i) + rqrcuten_p(i,k,j) = rqrcuten(k,i) + rqscuten_p(i,k,j) = rqscuten(k,i) enddo !decreases the characteristic time period that convection remains active. When nca_p !becomes less than the convective timestep, convective tendencies and precipitation !are reset to zero (note that this is also done in subroutine kf_eta_cps). - nca_p(i,j) = diag_physics % nca % array(i) + nca_p(i,j) = nca(i) do k = kts,kte - w0avg_p(i,k,j) = diag_physics % w0avg % array(k,i) + w0avg_p(i,k,j) = w0avg(k,i) enddo enddo enddo @@ -421,24 +480,21 @@ subroutine convection_from_MPAS(dt_dyn,mesh,sfc_input,diag_physics,tend_physics) case ("tiedtke") do j = jts,jte do i = its,ite - xland_p(i,j) = sfc_input % xland % array(i) - qfx_p(i,j) = diag_physics % qfx % array(i) + xland_p(i,j) = xland(i) + hfx_p(i,j) = hfx(i) + qfx_p(i,j) = qfx(i) enddo do k = kts,kte do i = its,ite - rqvdynblten_p(i,k,j) = tend_physics % rqvblten % array(k,i) - rqvdynten_p(i,k,j) = tend_physics % rqvdynten % array(k,i) - rucuten_p(i,k,j) = tend_physics % rucuten % array(k,i) - rvcuten_p(i,k,j) = tend_physics % rvcuten % array(k,i) + rqvdynblten_p(i,k,j) = rqvblten(k,i) + rqvdynten_p(i,k,j) = rqvdynten(k,i) + rucuten_p(i,k,j) = rucuten(k,i) + rvcuten_p(i,k,j) = rvcuten(k,i) enddo enddo enddo -! write(0,*) '--- max rqvdynblten = ',maxval(rqvdynblten_p(its:ite,kts:kte,jts:jte)) -! write(0,*) '--- min rqvdynblten = ',minval(rqvdynblten_p(its:ite,kts:kte,jts:jte)) -! write(0,*) '--- max rqvdynten = ',maxval(rqvdynten_p(its:ite,kts:kte,jts:jte)) -! write(0,*) '--- min rqvdynten = ',minval(rqvdynten_p(its:ite,kts:kte,jts:jte)) - + case default end select convection_select @@ -449,36 +505,57 @@ end subroutine convection_from_MPAS subroutine convection_to_MPAS(diag_physics,tend_physics) !================================================================================================== !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics + +!local pointers: + real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv + real(kind=RKIND),dimension(:,:),pointer:: w0avg + real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten,rqicuten,rqrcuten,rqscuten + real(kind=RKIND),dimension(:,:),pointer:: rucuten,rvcuten !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'nca' ,nca ) + call mpas_pool_get_array(diag_physics,'cubot' ,cubot ) + call mpas_pool_get_array(diag_physics,'cutop' ,cutop ) + call mpas_pool_get_array(diag_physics,'cuprec' ,cuprec ) + call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) + call mpas_pool_get_array(diag_physics,'w0avg' ,w0avg ) + call mpas_pool_get_array(tend_physics,'rthcuten',rthcuten) + call mpas_pool_get_array(tend_physics,'rqvcuten',rqvcuten) + call mpas_pool_get_array(tend_physics,'rqccuten',rqccuten) + call mpas_pool_get_array(tend_physics,'rqicuten',rqicuten) + call mpas_pool_get_array(tend_physics,'rqrcuten',rqrcuten) + call mpas_pool_get_array(tend_physics,'rqscuten',rqscuten) + call mpas_pool_get_array(tend_physics,'rucuten' ,rucuten ) + call mpas_pool_get_array(tend_physics,'rvcuten' ,rvcuten ) + do j = jts,jte do i = its,ite - diag_physics % raincv % array(i) = raincv_p(i,j) - diag_physics % cuprec % array(i) = pratec_p(i,j) + raincv(i) = raincv_p(i,j) + cuprec(i) = pratec_p(i,j) do k = kts, kte - tend_physics % rthcuten % array(k,i) = rthcuten_p(i,k,j) - tend_physics % rqvcuten % array(k,i) = rqvcuten_p(i,k,j) - tend_physics % rqccuten % array(k,i) = rqccuten_p(i,k,j) - tend_physics % rqicuten % array(k,i) = rqicuten_p(i,k,j) + rthcuten(k,i) = rthcuten_p(i,k,j) + rqvcuten(k,i) = rqvcuten_p(i,k,j) + rqccuten(k,i) = rqccuten_p(i,k,j) + rqicuten(k,i) = rqicuten_p(i,k,j) enddo enddo enddo - convection_select: select case(conv_deep_scheme) + convection_select: select case(convection_scheme) case ("kain_fritsch") do j = jts,jte do i = its,ite - diag_physics % cubot % array(i) = cubot_p(i,j) - diag_physics % cutop % array(i) = cutop_p(i,j) - diag_physics % nca % array(i) = nca_p(i,j) + cubot(i) = cubot_p(i,j) + cutop(i) = cutop_p(i,j) + nca(i) = nca_p(i,j) do k = kts, kte - diag_physics % w0avg % array(k,i) = w0avg_p(i,k,j) - tend_physics % rqrcuten % array(k,i) = rqrcuten_p(i,k,j) - tend_physics % rqscuten % array(k,i) = rqscuten_p(i,k,j) + w0avg(k,i) = w0avg_p(i,k,j) + rqrcuten(k,i) = rqrcuten_p(i,k,j) + rqscuten(k,i) = rqscuten_p(i,k,j) enddo enddo enddo @@ -487,8 +564,8 @@ subroutine convection_to_MPAS(diag_physics,tend_physics) do j = jts,jte do k = kts,kte do i = its,ite - tend_physics % rucuten % array(k,i) = rucuten_p(i,k,j) - tend_physics % rvcuten % array(k,i) = rvcuten_p(i,k,j) + rucuten(k,i) = rucuten_p(i,k,j) + rvcuten(k,i) = rvcuten_p(i,k,j) enddo enddo enddo @@ -503,41 +580,63 @@ end subroutine convection_to_MPAS subroutine update_convection_step1(mesh,diag_physics,tend_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics -!local variables: +!local pointers: + integer,pointer:: nCellsSolve,nVertLevels + + real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv + real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten,rqicuten,rqrcuten,rqscuten + +!local variables and arrays: integer:: iCell,k !-------------------------------------------------------------------------------------------------- - - convection_select: select case(conv_deep_scheme) + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) + + call mpas_pool_get_array(diag_physics,'nca' ,nca ) + call mpas_pool_get_array(diag_physics,'cubot' ,cubot ) + call mpas_pool_get_array(diag_physics,'cutop' ,cutop ) + call mpas_pool_get_array(diag_physics,'cuprec',cuprec) + call mpas_pool_get_array(diag_physics,'raincv',raincv) + + call mpas_pool_get_array(tend_physics,'rthcuten',rthcuten) + call mpas_pool_get_array(tend_physics,'rqvcuten',rqvcuten) + call mpas_pool_get_array(tend_physics,'rqccuten',rqccuten) + call mpas_pool_get_array(tend_physics,'rqicuten',rqicuten) + call mpas_pool_get_array(tend_physics,'rqrcuten',rqrcuten) + call mpas_pool_get_array(tend_physics,'rqscuten',rqscuten) + + convection_select: select case(convection_scheme) case ("kain_fritsch") - do iCell = 1, mesh%nCellsSolve + do iCell = 1, nCellsSolve !decreases the characteristic time period that convection remains active. When nca_p !becomes less than the convective timestep, convective tendencies and precipitation !are reset to zero (note that this is also done in subroutine kf_eta_cps). - if(diag_physics % nca % array(iCell) .gt. 0.) then - diag_physics % nca % array(iCell) = diag_physics % nca % array(iCell) - dt_dyn + if(nca(iCell) .gt. 0.) then + nca(iCell) = nca(iCell) - dt_dyn - if(diag_physics % nca % array(iCell) .lt. 0.5*dt_dyn) then - do k = 1, mesh%nVertLevels - tend_physics % rthcuten % array(k,iCell) = 0._RKIND - tend_physics % rqvcuten % array(k,iCell) = 0._RKIND - tend_physics % rqccuten % array(k,iCell) = 0._RKIND - tend_physics % rqrcuten % array(k,iCell) = 0._RKIND - tend_physics % rqicuten % array(k,iCell) = 0._RKIND - tend_physics % rqscuten % array(k,iCell) = 0._RKIND + if(nca(iCell) .lt. 0.5*dt_dyn) then + do k = 1, nVertLevels + rthcuten(k,iCell) = 0._RKIND + rqvcuten(k,iCell) = 0._RKIND + rqccuten(k,iCell) = 0._RKIND + rqrcuten(k,iCell) = 0._RKIND + rqicuten(k,iCell) = 0._RKIND + rqscuten(k,iCell) = 0._RKIND enddo - diag_physics % raincv % array(iCell) = 0._RKIND - diag_physics % cuprec % array(iCell) = 0._RKIND - diag_physics % cubot % array(iCell) = kte+1 - diag_physics % cutop % array(iCell) = kts + raincv(iCell) = 0._RKIND + cuprec(iCell) = 0._RKIND + cubot(iCell) = kte+1 + cutop(iCell) = kts endif endif enddo @@ -549,31 +648,44 @@ subroutine update_convection_step1(mesh,diag_physics,tend_physics) end subroutine update_convection_step1 !================================================================================================== - subroutine update_convection_step2(bucket_rainc,mesh,diag_physics) + subroutine update_convection_step2(configs,mesh,diag_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - real(kind=RKIND),intent(in):: bucket_rainc + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics -!local variables: +!local pointers: + integer,pointer:: nCellsSolve + integer,dimension(:),pointer:: i_rainc + + real(kind=RKIND),pointer:: bucket_rainc + real(kind=RKIND),dimension(:),pointer:: cuprec,rainc + +!local variables and arrays: integer:: iCell !-------------------------------------------------------------------------------------------------- - + + call mpas_pool_get_config(configs,'config_bucket_rainc',bucket_rainc) + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + + call mpas_pool_get_array(diag_physics,'i_rainc',i_rainc) + call mpas_pool_get_array(diag_physics,'cuprec' ,cuprec ) + call mpas_pool_get_array(diag_physics,'rainc' ,rainc ) + !update the accumulated precipitation at the end of each dynamic time-step: - do iCell = 1, mesh % nCellsSolve - diag_physics % rainc % array(iCell) = diag_physics % rainc % array(iCell) & - + diag_physics % cuprec % array(iCell) * dt_dyn + do iCell = 1, nCellsSolve + rainc(iCell) = rainc(iCell) + cuprec(iCell) * dt_dyn if(l_acrain .and. bucket_rainc.gt.0._RKIND .and. & - diag_physics%rainc%array(iCell).gt.bucket_rainc) then - diag_physics % i_rainc % array(iCell) = diag_physics % i_rainc % array(iCell) + 1 - diag_physics % rainc % array(iCell) = diag_physics % rainc % array(iCell) & - - bucket_rainc + rainc(iCell).gt.bucket_rainc) then + i_rainc(iCell) = i_rainc(iCell) + 1 + rainc(iCell) = rainc(iCell) - bucket_rainc endif enddo @@ -581,5 +693,5 @@ subroutine update_convection_step2(bucket_rainc,mesh,diag_physics) end subroutine update_convection_step2 !================================================================================================== - end module mpas_atmphys_driver_convection_deep + end module mpas_atmphys_driver_convection !================================================================================================== diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F index b44c631981..0882d62d51 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F @@ -7,7 +7,7 @@ ! !================================================================================================== module mpas_atmphys_driver_gwdo - use mpas_configure, only: len_disp => config_len_disp + use mpas_kind_types use mpas_grid_types use mpas_atmphys_constants @@ -48,10 +48,19 @@ module mpas_atmphys_driver_gwdo !> * removed the pre-processor option "do_hydrostatic_pressure" before call to subroutine gwdo. !> Laura D. Fowler (birch.ucar.edu) / 2013-05-29. !> * changed the definition of dx_p to the mean distance between cell centers. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-23. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-23. +!> * in call to subroutine gwdo, replaced the variable g (that originally pointed to gravity) +!> with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. + contains + !================================================================================================== subroutine allocate_gwdo !================================================================================================== @@ -109,44 +118,70 @@ subroutine gwdo_from_MPAS(mesh,sfc_input,diag_physics,tend_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(sfc_input_type),intent(in) :: sfc_input - type(diag_physics_type),intent(in):: diag_physics - type(tend_physics_type),intent(in):: tend_physics + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: sfc_input + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: tend_physics + +!local pointers: + integer,dimension(:),pointer:: kpbl + real(kind=RKIND),dimension(:),pointer :: oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4,con,var2d + real(kind=RKIND),dimension(:),pointer :: dcEdge_m,dusfcg,dvsfcg + real(kind=RKIND),dimension(:,:),pointer:: dtaux3d,dtauy3d,rublten,rvblten !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(sfc_input,'oa1' ,oa1 ) + call mpas_pool_get_array(sfc_input,'oa2' ,oa2 ) + call mpas_pool_get_array(sfc_input,'oa3' ,oa3 ) + call mpas_pool_get_array(sfc_input,'oa4' ,oa4 ) + call mpas_pool_get_array(sfc_input,'ol1' ,ol1 ) + call mpas_pool_get_array(sfc_input,'ol2' ,ol2 ) + call mpas_pool_get_array(sfc_input,'ol3' ,ol3 ) + call mpas_pool_get_array(sfc_input,'ol4' ,ol4 ) + call mpas_pool_get_array(sfc_input,'con' ,con ) + call mpas_pool_get_array(sfc_input,'var2d',var2d) + + call mpas_pool_get_array(diag_physics,'dcEdge_m',dcEdge_m) + call mpas_pool_get_array(diag_physics,'kpbl' ,kpbl ) + call mpas_pool_get_array(diag_physics,'dusfcg' ,dusfcg ) + call mpas_pool_get_array(diag_physics,'dvsfcg' ,dvsfcg ) + call mpas_pool_get_array(diag_physics,'dtaux3d' ,dtaux3d ) + call mpas_pool_get_array(diag_physics,'dtauy3d' ,dtauy3d ) + call mpas_pool_get_array(tend_physics,'rublten' ,rublten ) + call mpas_pool_get_array(tend_physics,'rvblten' ,rvblten ) + do j = jts,jte do i = its,ite - var2d_p(i,j) = sfc_input % var2d % array(i) - con_p(i,j) = sfc_input % con % array(i) - oa1_p(i,j) = sfc_input % oa1 % array(i) - oa2_p(i,j) = sfc_input % oa2 % array(i) - oa3_p(i,j) = sfc_input % oa3 % array(i) - oa4_p(i,j) = sfc_input % oa4 % array(i) - ol1_p(i,j) = sfc_input % ol1 % array(i) - ol2_p(i,j) = sfc_input % ol2 % array(i) - ol3_p(i,j) = sfc_input % ol3 % array(i) - ol4_p(i,j) = sfc_input % ol4 % array(i) + var2d_p(i,j) = var2d(i) + con_p(i,j) = con(i) + oa1_p(i,j) = oa1(i) + oa2_p(i,j) = oa2(i) + oa3_p(i,j) = oa3(i) + oa4_p(i,j) = oa4(i) + ol1_p(i,j) = ol1(i) + ol2_p(i,j) = ol2(i) + ol3_p(i,j) = ol3(i) + ol4_p(i,j) = ol4(i) enddo enddo do j = jts,jte do i = its,ite - dx_p(i,j) = diag_physics % dcEdge_m % array(i) - kpbl_p(i,j) = diag_physics % kpbl % array(i) - dusfcg_p(i,j) = diag_physics % dusfcg % array(i) - dvsfcg_p(i,j) = diag_physics % dvsfcg % array(i) + dx_p(i,j) = dcEdge_m(i) + kpbl_p(i,j) = kpbl(i) + dusfcg_p(i,j) = dusfcg(i) + dvsfcg_p(i,j) = dvsfcg(i) enddo enddo do j = jts,jte do k = kts,kte do i = its,ite - dtaux3d_p(i,k,j) = diag_physics % dtaux3d % array(k,i) - dtauy3d_p(i,k,j) = diag_physics % dtauy3d % array(k,i) - rublten_p(i,k,j) = tend_physics % rublten % array(k,i) - rvblten_p(i,k,j) = tend_physics % rvblten % array(k,i) + dtaux3d_p(i,k,j) = dtaux3d(k,i) + dtauy3d_p(i,k,j) = dtauy3d(k,i) + rublten_p(i,k,j) = rublten(k,i) + rvblten_p(i,k,j) = rvblten(k,i) enddo enddo enddo @@ -158,39 +193,44 @@ subroutine gwdo_to_MPAS(diag_physics,tend_physics) !================================================================================================== !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics + +!local pointers: + real(kind=RKIND),dimension(:),pointer :: dusfcg,dvsfcg + real(kind=RKIND),dimension(:,:),pointer:: dtaux3d,dtauy3d,rubldiff,rvbldiff,rublten,rvblten !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'dusfcg' ,dusfcg ) + call mpas_pool_get_array(diag_physics,'dvsfcg' ,dvsfcg ) + call mpas_pool_get_array(diag_physics,'dtaux3d' ,dtaux3d ) + call mpas_pool_get_array(diag_physics,'dtauy3d' ,dtauy3d ) + call mpas_pool_get_array(diag_physics,'rubldiff',rubldiff) + call mpas_pool_get_array(diag_physics,'rvbldiff',rvbldiff) + call mpas_pool_get_array(tend_physics,'rublten' ,rublten ) + call mpas_pool_get_array(tend_physics,'rvblten' ,rvblten ) + do j = jts,jte do i = its,ite - diag_physics % dusfcg % array(i) = dusfcg_p(i,j) - diag_physics % dvsfcg % array(i) = dvsfcg_p(i,j) + dusfcg(i) = dusfcg_p(i,j) + dvsfcg(i) = dvsfcg_p(i,j) enddo enddo do j = jts,jte do k = kts,kte do i = its,ite - diag_physics % dtaux3d % array(k,i) = dtaux3d_p(i,k,j) - diag_physics % dtauy3d % array(k,i) = dtauy3d_p(i,k,j) - diag_physics % rubldiff % array(k,i) = rublten_p(i,k,j)-tend_physics%rublten%array(k,i) - diag_physics % rvbldiff % array(k,i) = rvblten_p(i,k,j)-tend_physics%rvblten%array(k,i) - - tend_physics % rublten % array(k,i) = rublten_p(i,k,j) - tend_physics % rvblten % array(k,i) = rvblten_p(i,k,j) + dtaux3d(k,i) = dtaux3d_p(i,k,j) + dtauy3d(k,i) = dtauy3d_p(i,k,j) + rubldiff(k,i) = rublten_p(i,k,j)-rublten(k,i) + rvbldiff(k,i) = rvblten_p(i,k,j)-rvblten(k,i) + rublten(k,i) = rublten_p(i,k,j) + rvblten(k,i) = rvblten_p(i,k,j) enddo enddo enddo -!write(0,*) -!write(0,*) '--- end subroutine gwdo_to_MPAS:' -!do i = its,ite -! write(0,101) i,diag_physics%dusfcg%array(i),diag_physics%dvsfcg%array(i) -!enddo -!101 format(i8,2(1x,e15.8)) - end subroutine gwdo_to_MPAS !================================================================================================== @@ -198,21 +238,21 @@ subroutine driver_gwdo(itimestep,mesh,sfc_input,diag_physics,tend_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(sfc_input_type),intent(in):: sfc_input + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: sfc_input integer,intent(in):: itimestep !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics !local variables: integer:: i,iCell,iEdge real(kind=RKIND),dimension(:),allocatable:: dx_max !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine driver_gwdo: dt_pbl=',dt_pbl +! write(0,*) +! write(0,*) '--- enter subroutine driver_gwdo: dt_pbl=',dt_pbl !copy MPAS arrays to local arrays: call gwdo_from_MPAS(mesh,sfc_input,diag_physics,tend_physics) @@ -227,7 +267,7 @@ subroutine driver_gwdo(itimestep,mesh,sfc_input,diag_physics,tend_physics) rvblten = rvblten_p , dtaux3d = dtaux3d_p , dtauy3d = dtauy3d_p , & dusfcg = dusfcg_p , dvsfcg = dvsfcg_p , kpbl2d = kpbl_p , & itimestep = itimestep , dt = dt_pbl , dx = dx_p , & - cp = cp , g = g , rd = R_d , & + cp = cp , g = gravity , rd = R_d , & rv = R_v , ep1 = ep_1 , pi = pii , & var2d = var2d_p , oc12d = con_p , oa2d1 = oa1_p , & oa2d2 = oa2_p , oa2d3 = oa3_p , oa2d4 = oa4_p , & @@ -244,7 +284,7 @@ subroutine driver_gwdo(itimestep,mesh,sfc_input,diag_physics,tend_physics) !copy local arrays to MPAS grid: call gwdo_to_MPAS(diag_physics,tend_physics) - write(0,*) '--- end subroutine driver_gwdo' +! write(0,*) '--- end subroutine driver_gwdo' end subroutine driver_gwdo diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F index 40b81cab14..61be13b086 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -7,8 +7,8 @@ ! !================================================================================================== module mpas_atmphys_driver_lsm + use mpas_kind_types use mpas_grid_types - use mpas_configure use mpas_atmphys_constants use mpas_atmphys_landuse @@ -30,9 +30,7 @@ module mpas_atmphys_driver_lsm logical,parameter:: frpcpn = .false. logical,parameter:: rdlai2d = .false. -!urban physics: since MPAS does not plan to run the urban physics option, the two options -!below are defined locally: - integer,parameter,public:: isurban=1 +!urban physics: MPAS does not plan to run the urban physics option. integer,parameter:: sf_urban_physics = 0 !activate urban canopy model (=0: no urban canopy) integer,private:: i,j,k,n @@ -59,6 +57,14 @@ module mpas_atmphys_driver_lsm !> ---------------------------------------- !> * removed the pre-processor option "do_hydrostatic_pressure" before call to subroutine lsm. !> Laura D. Fowler (birch.ucar.edu) / 2013-05-29. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * moved the definition of isurban to landuse_init_forMPAS in mpas_atmphys_landuse.F. +!> isurban is now defined as a function of the input landuse data file. +!> Dominikus Heinzeller (IMK) / 2014-07-24. + !> !> DOCUMENTATION: !> ./physics_wrf/module_sf_noahdrv.F: main driver for the "NOAH" land-surface parameterization. @@ -68,8 +74,10 @@ module mpas_atmphys_driver_lsm !> .. ust_urb2d;frc_urb2d;utype_urb2d. !> Laura D. Fowler (01-18-2011). + contains + !================================================================================================== subroutine allocate_lsm !================================================================================================== @@ -203,91 +211,157 @@ subroutine lsm_from_MPAS(mesh,diag_physics,sfc_input) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(diag_physics_type),intent(inout):: diag_physics - type(sfc_input_type) ,intent(inout):: sfc_input - -!local variables: + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + integer,dimension(:),pointer:: isltyp,ivgtyp + + real(kind=RKIND),dimension(:),pointer :: acsnom,acsnow,canwat,chs,chs2,chklowq,cpm,cqs2,glw, & + grdflx,gsw,hfx,lai,lh,noahres,potevp,qfx,qgh,qsfc, & + qz0,br,sfc_albedo,sfc_emibck,sfc_emiss,sfcrunoff, & + smstav,smstot,snotime,snopcx,sr,udrunoff,z0,znt + real(kind=RKIND),dimension(:),pointer :: shdmin,shdmax,snoalb,sfc_albbck,snow,snowc,snowh,tmn, & + skintemp,vegfra,xice,xland + real(kind=RKIND),dimension(:),pointer :: raincv,rainncv + real(kind=RKIND),dimension(:,:),pointer:: sh2o,smcrel,smois,tslb,dzs + +!local variables and arrays: logical:: do_fill - integer:: ip,iEdg !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) + call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + call mpas_pool_get_array(diag_physics,'chs' ,chs ) + call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) + call mpas_pool_get_array(diag_physics,'chklowq' ,chklowq ) + call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) + call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'noahres' ,noahres ) + call mpas_pool_get_array(diag_physics,'potevp' ,potevp ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'qz0' ,qz0 ) + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) + call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emibck',sfc_emibck) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) + call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) + call mpas_pool_get_array(diag_physics,'snotime' ,snotime ) + call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) + call mpas_pool_get_array(diag_physics,'sr' ,sr ) + call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + + call mpas_pool_get_array(sfc_input,'isltyp' ,isltyp ) + call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) + call mpas_pool_get_array(sfc_input,'shdmin' ,shdmin ) + call mpas_pool_get_array(sfc_input,'shdmax' ,shdmax ) + call mpas_pool_get_array(sfc_input,'snoalb' ,snoalb ) + call mpas_pool_get_array(sfc_input,'sfc_albbck' ,sfc_albbck) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'skintemp' ,skintemp ) + call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + call mpas_pool_get_array(sfc_input,'dzs' ,dzs ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smcrel' ,smcrel ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + do n = 1,num_soils - dzs_p(n) = maxval(sfc_input%dzs%array(n,:)) + dzs_p(n) = maxval(dzs(n,:)) enddo do j = jts,jte do n = 1,num_soils do i = its,ite - sh2o_p(i,n,j) = sfc_input % sh2o % array(n,i) - smcrel_p(i,n,j) = sfc_input % smcrel % array(n,i) - smois_p(i,n,j) = sfc_input % smois % array(n,i) - tslb_p(i,n,j) = sfc_input % tslb % array(n,i) + sh2o_p(i,n,j) = sh2o(n,i) + smcrel_p(i,n,j) = smcrel(n,i) + smois_p(i,n,j) = smois(n,i) + tslb_p(i,n,j) = tslb(n,i) enddo enddo enddo do j = jts,jte do i = its,ite - acsnom_p(i,j) = diag_physics % acsnom % array(i) - acsnow_p(i,j) = diag_physics % acsnow % array(i) - canwat_p(i,j) = diag_physics % canwat % array(i) - chs_p(i,j) = diag_physics % chs % array(i) - chs2_p(i,j) = diag_physics % chs2 % array(i) - chklowq_p(i,j) = diag_physics % chklowq % array(i) - cpm_p(i,j) = diag_physics % cpm % array(i) - cqs2_p(i,j) = diag_physics % cqs2 % array(i) - glw_p(i,j) = diag_physics % glw % array(i) - grdflx_p(i,j) = diag_physics % grdflx % array(i) - gsw_p(i,j) = diag_physics % gsw % array(i) - hfx_p(i,j) = diag_physics % hfx % array(i) - lai_p(i,j) = diag_physics % lai % array(i) - lh_p(i,j) = diag_physics % lh % array(i) - noahres_p(i,j) = diag_physics % noahres % array(i) - potevp_p(i,j) = diag_physics % potevp % array(i) - qfx_p(i,j) = diag_physics % qfx % array(i) - qgh_p(i,j) = diag_physics % qgh % array(i) - qsfc_p(i,j) = diag_physics % qsfc % array(i) - qz0_p(i,j) = diag_physics % qz0 % array(i) - br_p(i,j) = diag_physics % br % array(i) - sfc_albedo_p(i,j) = diag_physics % sfc_albedo % array(i) - sfc_emibck_p(i,j) = diag_physics % sfc_emibck % array(i) - sfc_emiss_p(i,j) = diag_physics % sfc_emiss % array(i) - sfcrunoff_p(i,j) = diag_physics % sfcrunoff % array(i) - smstav_p(i,j) = diag_physics % smstav % array(i) - smstot_p(i,j) = diag_physics % smstot % array(i) - snotime_p(i,j) = diag_physics % snotime % array(i) - snopcx_p(i,j) = diag_physics % snopcx % array(i) - sr_p(i,j) = diag_physics % sr % array(i) - udrunoff_p(i,j) = diag_physics % udrunoff % array(i) - z0_p(i,j) = diag_physics % z0 % array(i) - znt_p(i,j) = diag_physics % znt % array(i) - - isltyp_p(i,j) = sfc_input % isltyp % array(i) - ivgtyp_p(i,j) = sfc_input % ivgtyp % array(i) - shdmin_p(i,j) = sfc_input % shdmin % array(i) - shdmax_p(i,j) = sfc_input % shdmax % array(i) - snoalb_p(i,j) = sfc_input % snoalb % array(i) - sfc_albbck_p(i,j) = sfc_input % sfc_albbck % array(i) - snow_p(i,j) = sfc_input % snow % array(i) - snowc_p(i,j) = sfc_input % snowc % array(i) - snowh_p(i,j) = sfc_input % snowh % array(i) - tmn_p(i,j) = sfc_input % tmn % array(i) - tsk_p(i,j) = sfc_input % skintemp % array(i) - vegfra_p(i,j) = sfc_input % vegfra % array(i) - xice_p(i,j) = sfc_input % xice % array(i) - xland_p(i,j) = sfc_input % xland % array(i) + acsnom_p(i,j) = acsnom(i) + acsnow_p(i,j) = acsnow(i) + canwat_p(i,j) = canwat(i) + chs_p(i,j) = chs(i) + chs2_p(i,j) = chs2(i) + chklowq_p(i,j) = chklowq(i) + cpm_p(i,j) = cpm(i) + cqs2_p(i,j) = cqs2(i) + glw_p(i,j) = glw(i) + grdflx_p(i,j) = grdflx(i) + gsw_p(i,j) = gsw(i) + hfx_p(i,j) = hfx(i) + lai_p(i,j) = lai(i) + lh_p(i,j) = lh(i) + noahres_p(i,j) = noahres(i) + potevp_p(i,j) = potevp(i) + qfx_p(i,j) = qfx(i) + qgh_p(i,j) = qgh(i) + qsfc_p(i,j) = qsfc(i) + qz0_p(i,j) = qz0(i) + br_p(i,j) = br(i) + sfc_albedo_p(i,j) = sfc_albedo(i) + sfc_emibck_p(i,j) = sfc_emibck(i) + sfc_emiss_p(i,j) = sfc_emiss(i) + sfcrunoff_p(i,j) = sfcrunoff(i) + smstav_p(i,j) = smstav(i) + smstot_p(i,j) = smstot(i) + snotime_p(i,j) = snotime(i) + snopcx_p(i,j) = snopcx(i) + sr_p(i,j) = sr(i) + udrunoff_p(i,j) = udrunoff(i) + z0_p(i,j) = z0(i) + znt_p(i,j) = znt(i) + + isltyp_p(i,j) = isltyp(i) + ivgtyp_p(i,j) = ivgtyp(i) + shdmin_p(i,j) = shdmin(i) + shdmax_p(i,j) = shdmax(i) + snoalb_p(i,j) = snoalb(i) + sfc_albbck_p(i,j) = sfc_albbck(i) + snow_p(i,j) = snow(i) + snowc_p(i,j) = snowc(i) + snowh_p(i,j) = snowh(i) + tmn_p(i,j) = tmn(i) + tsk_p(i,j) = skintemp(i) + vegfra_p(i,j) = vegfra(i) + xice_p(i,j) = xice(i) + xland_p(i,j) = xland(i) enddo enddo do j = jts,jte do i = its,ite - rainbl_p(i,j) = diag_physics % raincv % array(i) + diag_physics % rainncv % array(i) - swdown_p(i,j) = diag_physics % gsw % array(i) & - / (1. - diag_physics % sfc_albedo % array(i)) + rainbl_p(i,j) = raincv(i) + rainncv(i) + swdown_p(i,j) = gsw(i) / (1._RKIND - sfc_albedo(i)) enddo enddo @@ -298,131 +372,206 @@ subroutine lsm_to_MPAS(mesh,diag_physics,sfc_input) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(diag_physics_type),intent(inout):: diag_physics - type(sfc_input_type) ,intent(inout):: sfc_input - + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + integer,dimension(:),pointer:: isltyp,ivgtyp + + real(kind=RKIND),dimension(:),pointer :: acsnom,acsnow,canwat,chs,chs2,chklowq,cpm,cqs2,glw, & + grdflx,gsw,hfx,lai,lh,noahres,potevp,qfx,qgh,qsfc, & + qz0,br,sfc_albedo,sfc_emibck,sfc_emiss,sfcrunoff, & + smstav,smstot,snotime,snopcx,sr,udrunoff,z0,znt + real(kind=RKIND),dimension(:),pointer :: shdmin,shdmax,snoalb,sfc_albbck,snow,snowc,snowh,tmn, & + skintemp,vegfra,xice,xland + real(kind=RKIND),dimension(:),pointer :: raincv,rainncv + real(kind=RKIND),dimension(:,:),pointer:: sh2o,smcrel,smois,tslb + +!local variables and arrays: integer:: ip,iEdg !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) + call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + call mpas_pool_get_array(diag_physics,'chs' ,chs ) + call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) + call mpas_pool_get_array(diag_physics,'chklowq' ,chklowq ) + call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) + call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'noahres' ,noahres ) + call mpas_pool_get_array(diag_physics,'potevp' ,potevp ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'qz0' ,qz0 ) + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) + call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emibck',sfc_emibck) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) + call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) + call mpas_pool_get_array(diag_physics,'snotime' ,snotime ) + call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) + call mpas_pool_get_array(diag_physics,'sr' ,sr ) + call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + + call mpas_pool_get_array(sfc_input,'isltyp' ,isltyp ) + call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) + call mpas_pool_get_array(sfc_input,'shdmin' ,shdmin ) + call mpas_pool_get_array(sfc_input,'shdmax' ,shdmax ) + call mpas_pool_get_array(sfc_input,'snoalb' ,snoalb ) + call mpas_pool_get_array(sfc_input,'sfc_albbck' ,sfc_albbck) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'skintemp' ,skintemp ) + call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smcrel' ,smcrel ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + do j = jts,jte do n = 1,num_soils do i = its,ite - sfc_input % sh2o % array(n,i) = sh2o_p(i,n,j) - sfc_input % smcrel % array(n,i) = smcrel_p(i,n,j) - sfc_input % smois % array(n,i) = smois_p(i,n,j) - sfc_input % tslb % array(n,i) = tslb_p(i,n,j) + sh2o(n,i) = sh2o_p(i,n,j) + smcrel(n,i) = smcrel_p(i,n,j) + smois(n,i) = smois_p(i,n,j) + tslb(n,i) = tslb_p(i,n,j) enddo enddo enddo do j = jts,jte do i = its,ite - diag_physics % acsnom % array(i) = acsnom_p(i,j) - diag_physics % acsnow % array(i) = acsnow_p(i,j) - diag_physics % canwat % array(i) = canwat_p(i,j) - diag_physics % chs % array(i) = chs_p(i,j) - diag_physics % chs2 % array(i) = chs2_p(i,j) - diag_physics % chklowq % array(i) = chklowq_p(i,j) - diag_physics % cpm % array(i) = cpm_p(i,j) - diag_physics % cqs2 % array(i) = cqs2_p(i,j) - diag_physics % glw % array(i) = glw_p(i,j) - diag_physics % grdflx % array(i) = grdflx_p(i,j) - diag_physics % gsw % array(i) = gsw_p(i,j) - diag_physics % hfx % array(i) = hfx_p(i,j) - diag_physics % lai % array(i) = lai_p(i,j) - diag_physics % lh % array(i) = lh_p(i,j) - diag_physics % noahres % array(i) = noahres_p(i,j) - diag_physics % potevp % array(i) = potevp_p(i,j) - diag_physics % qfx % array(i) = qfx_p(i,j) - diag_physics % qgh % array(i) = qgh_p(i,j) - diag_physics % qsfc % array(i) = qsfc_p(i,j) - diag_physics % qz0 % array(i) = qz0_p(i,j) - diag_physics % br % array(i) = br_p(i,j) - diag_physics % sfc_albedo % array(i) = sfc_albedo_p(i,j) - diag_physics % sfc_emibck % array(i) = sfc_emibck_p(i,j) - diag_physics % sfc_emiss % array(i) = sfc_emiss_p(i,j) - diag_physics % sfcrunoff % array(i) = sfcrunoff_p(i,j) - diag_physics % smstav % array(i) = smstav_p(i,j) - diag_physics % smstot % array(i) = smstot_p(i,j) - diag_physics % snotime % array(i) = snotime_p(i,j) - diag_physics % snopcx % array(i) = snopcx_p(i,j) - diag_physics % sr % array(i) = sr_p(i,j) - diag_physics % udrunoff % array(i) = udrunoff_p(i,j) - diag_physics % z0 % array(i) = z0_p(i,j) - diag_physics % znt % array(i) = znt_p(i,j) - - !not needed ?: - sfc_input % isltyp % array(i) = isltyp_p(i,j) - sfc_input % ivgtyp % array(i) = ivgtyp_p(i,j) - sfc_input % shdmin % array(i) = shdmin_p(i,j) - sfc_input % shdmax % array(i) = shdmax_p(i,j) - sfc_input % snoalb % array(i) = snoalb_p(i,j) - sfc_input % sfc_albbck % array(i) = sfc_albbck_p(i,j) - sfc_input % snow % array(i) = snow_p(i,j) - sfc_input % snowc % array(i) = snowc_p(i,j) - sfc_input % snowh % array(i) = snowh_p(i,j) - sfc_input % skintemp % array(i) = tsk_p(i,j) - sfc_input % tmn % array(i) = tmn_p(i,j) - sfc_input % vegfra % array(i) = vegfra_p(i,j) - sfc_input % xice % array(i) = xice_p(i,j) - sfc_input % xland % array(i) = xland_p(i,j) - + acsnom(i) = acsnom_p(i,j) + acsnow(i) = acsnow_p(i,j) + canwat(i) = canwat_p(i,j) + chs(i) = chs_p(i,j) + chs2(i) = chs2_p(i,j) + chklowq(i) = chklowq_p(i,j) + cpm(i) = cpm_p(i,j) + cqs2(i) = cqs2_p(i,j) + glw(i) = glw_p(i,j) + grdflx(i) = grdflx_p(i,j) + gsw(i) = gsw_p(i,j) + hfx(i) = hfx_p(i,j) + lai(i) = lai_p(i,j) + lh(i) = lh_p(i,j) + noahres(i) = noahres_p(i,j) + potevp(i) = potevp_p(i,j) + qfx(i) = qfx_p(i,j) + qgh(i) = qgh_p(i,j) + qsfc(i) = qsfc_p(i,j) + qz0(i) = qz0_p(i,j) + br(i) = br_p(i,j) + sfc_albedo(i) = sfc_albedo_p(i,j) + sfc_emibck(i) = sfc_emibck_p(i,j) + sfc_emiss(i) = sfc_emiss_p(i,j) + sfcrunoff(i) = sfcrunoff_p(i,j) + smstav(i) = smstav_p(i,j) + smstot(i) = smstot_p(i,j) + snotime(i) = snotime_p(i,j) + snopcx(i) = snopcx_p(i,j) + sr(i) = sr_p(i,j) + udrunoff(i) = udrunoff_p(i,j) + z0(i) = z0_p(i,j) + znt(i) = znt_p(i,j) + + isltyp(i) = isltyp_p(i,j) + ivgtyp(i) = ivgtyp_p(i,j) + shdmin(i) = shdmin_p(i,j) + shdmax(i) = shdmax_p(i,j) + snoalb(i) = snoalb_p(i,j) + sfc_albbck(i) = sfc_albbck_p(i,j) + snow(i) = snow_p(i,j) + snowc(i) = snowc_p(i,j) + snowh(i) = snowh_p(i,j) + skintemp(i) = tsk_p(i,j) + tmn(i) = tmn_p(i,j) + vegfra(i) = vegfra_p(i,j) + xice(i) = xice_p(i,j) + xland(i) = xland_p(i,j) enddo enddo end subroutine lsm_to_MPAS !================================================================================================== - subroutine init_lsm(dminfo,mesh,diag_physics,sfc_input) + subroutine init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) !================================================================================================== !input arguments: type(dm_info),intent(in):: dminfo - type(mesh_type):: mesh + type(mpas_pool_type):: mesh + type(mpas_pool_type),intent(in):: configs !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(sfc_input_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter land surface model initialization:' +! write(0,*) +! write(0,*) '--- enter land surface model initialization:' lsm_select: select case (trim(lsm_scheme)) case ("noah") - write(0,*) ' enter subroutine noah_init_forMPAS:' - call noah_init_forMPAS(dminfo,mesh,diag_physics,sfc_input) - write(0,*) ' end subroutine noah_init_forMPAS' +! write(0,*) ' enter subroutine noah_init_forMPAS:' + call noah_init_forMPAS(dminfo,mesh,configs,diag_physics,sfc_input) +! write(0,*) ' end subroutine noah_init_forMPAS' case default end select lsm_select - write(0,*) '--- end land surface model initialization' +! write(0,*) '--- end land surface model initialization' end subroutine init_lsm !================================================================================================== - subroutine driver_lsm(itimestep,mesh,diag_physics,sfc_input) + subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input) !================================================================================================== !input arguments: integer,intent(in):: itimestep - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(sfc_input_type),intent(inout) :: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + logical,pointer:: config_sfc_albedo + character(len=StrKIND),pointer:: mminlu !--------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine driver_lsm:' - write(0,*) '--- isice = ',isice - write(0,*) '--- iswater = ', iswater - write(0,*) '--- isurban = ', isurban +! write(0,*) +! write(0,*) '--- enter subroutine driver_lsm:' +! write(0,*) '--- isice = ',isice +! write(0,*) '--- iswater = ', iswater +! write(0,*) '--- isurban = ', isurban + + call mpas_pool_get_config(configs,'config_sfc_albedo' ,config_sfc_albedo ) + call mpas_pool_get_array(sfc_input,'mminlu',mminlu) !formats: 101 format(2i6,8(1x,e15.8)) @@ -430,6 +579,7 @@ subroutine driver_lsm(itimestep,mesh,diag_physics,sfc_input) !copy MPAS arrays to local arrays: call lsm_from_MPAS(mesh,diag_physics,sfc_input) +! write(0,*) '--- end lsm_from_MPAS' !call to land-surface scheme: lsm_select: select case (trim(lsm_scheme)) @@ -460,12 +610,12 @@ subroutine driver_lsm(itimestep,mesh,diag_physics,sfc_input) itimestep = itimestep , frpcpn = frpcpn , rdlai2d = rdlai2d , & xice_threshold = xice_threshold , & usemonalb = config_sfc_albedo , & - mminlu = input_landuse_data , & - num_soil_layers = num_soil_layers , & - num_roof_layers = num_soil_layers , & - num_wall_layers = num_soil_layers , & - num_road_layers = num_soil_layers , & - num_urban_layers = num_soil_layers , & + mminlu = mminlu , & + num_soil_layers = num_soils , & + num_roof_layers = num_soils , & + num_wall_layers = num_soils , & + num_road_layers = num_soils , & + num_urban_layers = num_soils , & sf_urban_physics = sf_urban_physics , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & @@ -478,7 +628,7 @@ subroutine driver_lsm(itimestep,mesh,diag_physics,sfc_input) !copy local arrays to MPAS grid: call lsm_to_MPAS(mesh,diag_physics,sfc_input) - write(0,*) '--- end subroutine driver_lsm' +! write(0,*) '--- end subroutine driver_lsm' end subroutine driver_lsm diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F index 723e5ea734..69bea5fdb1 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F @@ -7,12 +7,12 @@ ! !================================================================================================== module mpas_atmphys_driver_microphysics - use mpas_configure + use mpas_kind_types use mpas_grid_types use mpas_atmphys_constants use mpas_atmphys_vars - use mpas_atmphys_interface_nhyd + use mpas_atmphys_interface !wrf physics: use module_mp_kessler @@ -55,14 +55,24 @@ module mpas_atmphys_driver_microphysics !> ---------------------------------------- !> * removed call to the Thompson cloud microphysics scheme until the scheme is updated to that !> in WRF revision 3.5. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-05-29. +!> Laura D. Fowler (laura@ucar.edu) / 2013-05-29. !> * added subroutine compute_relhum to calculate the relative humidity using the functions !> rslf and rsif from the Thompson cloud microphysics scheme. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-12. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-12. +!> * removed the argument tend from the call to microphysics_from_MPAS (not needed). +!> Laura D. Fowler (laura@ucar.edu) / 2013-11-07. +!> * in call to subroutine wsm6, replaced the variable g (that originally pointed to gravity) +!> with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * Modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. contains + !================================================================================================== subroutine allocate_microphysics !================================================================================================== @@ -150,63 +160,63 @@ end subroutine deallocate_microphysics !================================================================================================== subroutine microphysics_init !================================================================================================== - write(0,*) - write(0,*) '--- enter cloud microphysics initialization:' +! write(0,*) +! write(0,*) '--- enter cloud microphysics initialization:' microp_select: select case(microp_scheme) case("wsm6") - write(0,*) '--- enter subroutine wsm6init:' +! write(0,*) '--- enter subroutine wsm6init:' call wsm6init(rho_a,rho_r,rho_s,cliq,cpv,.false.) - write(0,*) '--- end subroutine wsm6init' +! write(0,*) '--- end subroutine wsm6init' case default end select microp_select - write(0,*) '--- end cloud microphysics initialization' +! write(0,*) '--- end cloud microphysics initialization' end subroutine microphysics_init !================================================================================================== - subroutine microphysics_driver(state,diag,diag_physics,tend,mesh,itimestep) + subroutine microphysics_driver(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep) !================================================================================================== !input arguments: -!---------------- - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + + integer,intent(in):: time_lev integer,intent(in):: itimestep !inout arguments: -!---------------- - type(state_type),intent(inout):: state - type(diag_type),intent(inout):: diag - type(diag_physics_type),intent(inout):: diag_physics - type(tend_type),intent(inout):: tend + type(mpas_pool_type),intent(inout):: state + type(mpas_pool_type),intent(inout):: diag + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend !local variables and arrays: -!--------------------------- logical:: log_microphysics integer:: i,icell,icount,istep,j,k,kk !================================================================================================== - write(0,*) - write(0,*) '--- enter subroutine microphysics_driver: itimestep=', itimestep - write(0,*) ' dt_microp=',dt_microp - write(0,*) ' n_microp =',n_microp +! write(0,*) +! write(0,*) '--- enter subroutine microphysics_driver: itimestep=', itimestep +! write(0,*) ' dt_microp=',dt_microp +! write(0,*) ' n_microp =',n_microp !initialization: - write(0,*) ' ims= ',ims,' ime=',ime - write(0,*) ' jms= ',jms,' jme=',jme - write(0,*) ' kms= ',kms,' kme=',kme - write(0,*) - write(0,*) ' ids= ',ids,' ide=',ide - write(0,*) ' jds= ',jds,' jde=',jde - write(0,*) ' kds= ',kds,' kde=',kde - write(0,*) - write(0,*) ' its= ',its,' ite=',ite - write(0,*) ' jts= ',jts,' jte=',jte - write(0,*) ' kts= ',kts,' kte=',kte +! write(0,*) ' ims= ',ims,' ime=',ime +! write(0,*) ' jms= ',jms,' jme=',jme +! write(0,*) ' kms= ',kms,' kme=',kme +! write(0,*) +! write(0,*) ' ids= ',ids,' ide=',ide +! write(0,*) ' jds= ',jds,' jde=',jde +! write(0,*) ' kds= ',kds,' kde=',kde +! write(0,*) +! write(0,*) ' its= ',its,' ite=',ite +! write(0,*) ' jts= ',jts,' jte=',jte +! write(0,*) ' kts= ',kts,' kte=',kte !... allocation of microphysics arrays: call allocate_microphysics @@ -215,7 +225,7 @@ subroutine microphysics_driver(state,diag,diag_physics,tend,mesh,itimestep) call precip_from_MPAS(diag_physics,mesh) !... initialization of soundings for non-hydrostatic dynamical cores. - call microphysics_from_MPAS(mesh,state,tend,diag) + call microphysics_from_MPAS(mesh,state,time_lev,diag) !-------------------------------------------------------------------------------------------------- @@ -243,7 +253,7 @@ subroutine microphysics_driver(state,diag,diag_physics,tend,mesh,itimestep) ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - write(0,*) '--- end kessler:',istep +! write(0,*) '--- end kessler:',istep case ("wsm6") call wsm6( & @@ -251,7 +261,7 @@ subroutine microphysics_driver(state,diag,diag_physics,tend,mesh,itimestep) qr = qr_p , qi = qi_p , qs = qs_p , & qg = qg_p , den = rho_p , pii = pi_p , & p = pres_p , delz = dz_p , delt = dt_microp , & - g = g , cpd = cp , cpv = cpv , & + g = gravity , cpd = cp , cpv = cpv , & rd = R_d , rv = R_v , t0c = svpt0 , & ep1 = ep_1 , ep2 = ep_2 , qmin = epsilon , & xls = xls , xlv0 = xlv , xlf0 = xlf , & @@ -263,7 +273,7 @@ subroutine microphysics_driver(state,diag,diag_physics,tend,mesh,itimestep) ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - write(0,*) '--- end wsm6:',istep +! write(0,*) '--- end wsm6:',istep case default @@ -287,16 +297,16 @@ subroutine microphysics_driver(state,diag,diag_physics,tend,mesh,itimestep) ! calculate the relative humidity over water if the temperature is strictly greater than 0.C, ! over ice otherwise. - call compute_relhum(diag_physics) + call compute_relhum(mesh,diag_physics) end if !... copy updated precipitation from the wrf-physics grid back to the geodesic-dynamics grid: - call precip_to_MPAS(config_bucket_rainnc,diag_physics) + call precip_to_MPAS(configs,mesh,diag_physics) !... copy updated cloud microphysics variables from the wrf-physics grid back to the geodesic- ! dynamics grid: - call microphysics_to_MPAS(mesh,state,diag,tend,itimestep) + call microphysics_to_MPAS(mesh,state,time_lev,diag,tend,itimestep) !... deallocation of all microphysics arrays: call deallocate_microphysics @@ -314,16 +324,27 @@ subroutine precip_from_MPAS(diag_physics,mesh) !================================================================================================== !input variables: - type(mesh_type) ,intent(in):: mesh + type(mpas_pool_type) ,intent(in):: mesh !output variables: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics -!local variables: +!local pointers: + integer,pointer:: nCellsSolve + real,dimension(:),pointer:: graupelncv,rainncv,snowncv,sr + +!local variables and arrays: integer:: i,iCell,j !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + + call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) + call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) + call mpas_pool_get_array(diag_physics,'sr' ,sr ) + !variables common to all cloud microphysics schemes: do j = jts, jte do i = its, ite @@ -332,8 +353,8 @@ subroutine precip_from_MPAS(diag_physics,mesh) enddo enddo - do iCell = 1, mesh % nCellsSolve - diag_physics % rainncv % array(iCell) = 0._RKIND + do iCell = 1, nCellsSolve + rainncv(iCell) = 0._RKIND enddo !variables specific to different cloud microphysics schemes: @@ -352,10 +373,10 @@ subroutine precip_from_MPAS(diag_physics,mesh) enddo enddo - do iCell = 1, mesh % nCellsSolve - diag_physics % snowncv % array(iCell) = 0._RKIND - diag_physics % graupelncv % array(iCell) = 0._RKIND - diag_physics % sr % array(iCell) = 0._RKIND + do iCell = 1, nCellsSolve + snowncv(iCell) = 0._RKIND + graupelncv(iCell) = 0._RKIND + sr(iCell) = 0._RKIND enddo case default @@ -365,43 +386,70 @@ subroutine precip_from_MPAS(diag_physics,mesh) end subroutine precip_from_MPAS !================================================================================================== - subroutine precip_to_MPAS(bucket_rainnc,diag_physics) + subroutine precip_to_MPAS(configs,mesh,diag_physics) !================================================================================================== -!output variables: - real(kind=RKIND),intent(in):: bucket_rainnc - type(diag_physics_type),intent(inout):: diag_physics +!input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + +!inout arguments: + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + integer,pointer:: nCellsSolve + integer,dimension(:),pointer:: i_rainnc -!local variables: + real(kind=RKIND),pointer:: config_bucket_rainnc + real(kind=RKIND),dimension(:),pointer:: precipw + real(kind=RKIND),dimension(:),pointer:: graupelnc,rainnc,snownc + real(kind=RKIND),dimension(:),pointer:: graupelncv,rainncv,snowncv,sr + +!local variables and arrays: integer:: i,j,k real(kind=RKIND):: rho_a !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_bucket_rainnc',config_bucket_rainnc) + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + + call mpas_pool_get_array(diag_physics,'i_rainnc' ,i_rainnc ) + call mpas_pool_get_array(diag_physics,'precipw' ,precipw ) + call mpas_pool_get_array(diag_physics,'graupelnc' ,graupelnc ) + call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) + call mpas_pool_get_array(diag_physics,'rainnc' ,rainnc ) + call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'snownc' ,snownc ) + call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) + call mpas_pool_get_array(diag_physics,'sr' ,sr ) + + do i = 1, nCellsSolve + precipw(i) = 0._RKIND + enddo + !variables common to all cloud microphysics schemes: do j = jts,jte do i = its,ite !precipitable water: - diag_physics % precipw % array(i) = 0._RKIND do k = kts,kte rho_a = rho_p(i,k,j) / (1._RKIND + qv_p(i,k,j)) - diag_physics % precipw % array(i) = & - diag_physics % precipw % array(i) + qv_p(i,k,j) * rho_a * dz_p(i,k,j) + precipw(i) = precipw(i) + qv_p(i,k,j) * rho_a * dz_p(i,k,j) enddo !time-step precipitation: - diag_physics % rainncv % array(i) = rainnc_p(i,j) + rainncv(i) = rainnc_p(i,j) !accumulated precipitation: - diag_physics % rainnc % array(i) = diag_physics % rainnc % array(i) & - + diag_physics % rainncv % array(i) + rainnc(i) = rainnc(i) + rainncv(i) - if(l_acrain .and. bucket_rainnc.gt.0._RKIND .and. & - diag_physics%rainnc%array(i).gt.bucket_rainnc) then - diag_physics % i_rainnc % array(i) = diag_physics % i_rainnc % array(i) + 1 - diag_physics % rainnc % array(i) = diag_physics % rainnc % array(i) - bucket_rainnc + if(l_acrain .and. config_bucket_rainnc.gt.0._RKIND .and. & + rainnc(i).gt.config_bucket_rainnc) then + i_rainnc(i) = i_rainnc(i) + 1 + rainnc(i) = rainnc(i) - config_bucket_rainnc endif enddo @@ -417,16 +465,13 @@ subroutine precip_to_MPAS(bucket_rainnc,diag_physics) do i = its,ite !time-step precipitation: - diag_physics % snowncv % array(i) = snownc_p(i,j) - diag_physics % graupelncv % array(i) = graupelnc_p(i,j) - diag_physics % sr % array(i) = & - (snownc_p(i,j) + graupelnc_p(i,j)) / (rainnc_p(i,j)+1.e-12) + snowncv(i) = snownc_p(i,j) + graupelncv(i) = graupelnc_p(i,j) + sr(i) = (snownc_p(i,j) + graupelnc_p(i,j)) / (rainnc_p(i,j)+1.e-12) !accumulated precipitation: - diag_physics % snownc % array(i) = diag_physics % snownc % array(i) & - + diag_physics % snowncv % array(i) - diag_physics % graupelnc % array(i) = diag_physics % graupelnc % array(i) & - + diag_physics % graupelncv % array(i) + snownc(i) = snownc(i) + snowncv(i) + graupelnc(i) = graupelnc(i) + graupelncv(i) enddo enddo @@ -442,9 +487,12 @@ subroutine compute_radar_reflectivity(diag_physics) !================================================================================================== !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics -!local variables: +!local pointers: + real(kind=RKIND),dimension(:),pointer:: refl10cm_max + +!local variables and arrays: integer:: i,j,k real(kind=RKIND),dimension(:),allocatable:: qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ1d @@ -452,6 +500,8 @@ subroutine compute_radar_reflectivity(diag_physics) !write(0,*) !write(0,*) '--- enter subroutine COMPUTE_RADAR_REFLECTIVITY:' + call mpas_pool_get_array(diag_physics,'refl10cm_max',refl10cm_max) + microp_select: select case(microp_scheme) case ("kessler") @@ -486,9 +536,8 @@ subroutine compute_radar_reflectivity(diag_physics) dBZ1d(k) = max(-35._RKIND,dBZ1d(k)) ! write(0,201) i,k,dBZ1d(k) enddo - diag_physics % refl10cm_max % array(i) = maxval(dBZ1d(:)) -! if(diag_physics % refl10cm_max % array(i) .gt. 0.) & -! write(0,201) j,i,diag_physics % refl10cm_max % array(i) + refl10cm_max(i) = maxval(dBZ1d(:)) +! if(refl10cm_max(i) .gt. 0.) write(0,201) j,i,refl10cm_max(i) enddo enddo @@ -510,20 +559,33 @@ subroutine compute_radar_reflectivity(diag_physics) end subroutine compute_radar_reflectivity !================================================================================================== - subroutine compute_relhum(diag_physics) + subroutine compute_relhum(mesh,diag_physics) !================================================================================================== +!input arguments: + type(mpas_pool_type),intent(in):: mesh + !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics -!local variables: +!local pointers: + integer,pointer:: nCellsSolve,nVertLevels + real(kind=RKIND),dimension(:,:),pointer:: relhum + +!local variables and arrays: integer:: i,j,k + real(kind=RKIND):: tempc real(kind=RKIND),dimension(:),allocatable:: qv1d,qvs1d,t1d,p1d !-------------------------------------------------------------------------------------------------- - diag_physics % relhum % array(:,:) = 0._RKIND + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) + + call mpas_pool_get_array(diag_physics,'relhum',relhum) + + relhum(1:nVertLevels,1:nCellsSolve) = 0._RKIND if(.not.allocated(p1d) ) allocate(p1d(kts:kte) ) if(.not.allocated(t1d) ) allocate(t1d(kts:kte) ) @@ -540,7 +602,7 @@ subroutine compute_relhum(diag_physics) qvs1d(k) = rslf(p1d(k),t1d(k)) if(tempc .le. 0._RKIND) qvs1d(k) = rsif(p1d(k),t1d(k)) qv1d(k) = qv_p(i,k,j) - diag_physics % relhum % array(k,i) = qv1d(k) / qvs1d(k) + relhum(k,i) = qv1d(k) / qvs1d(k) enddo enddo diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 85ef239786..1d0cacca38 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -7,6 +7,7 @@ ! !================================================================================================== module mpas_atmphys_driver_pbl + use mpas_kind_types use mpas_grid_types use mpas_atmphys_constants @@ -46,9 +47,18 @@ module mpas_atmphys_driver_pbl !> ---------------------------------------- !> * removed the pre-processor option "do_hydrostatic_pressure" before call to subroutine ysu. !> Laura D. Fowler (birch.ucar.edu) / 2013-05-29. +!> * in call to subroutine ysu, replaced the variable g (that originally pointed to gravity) +!> with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * Modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. + contains + !================================================================================================== subroutine allocate_pbl !================================================================================================== @@ -130,29 +140,48 @@ subroutine pbl_from_MPAS(sfc_input,diag_physics) !================================================================================================== !input arguments: - type(diag_physics_type),intent(in):: diag_physics - type(sfc_input_type),intent(in) :: sfc_input + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: sfc_input + +!local pointers: + real(kind=RKIND),dimension(:),pointer:: xland + real(kind=RKIND),dimension(:),pointer:: br,gz1oz0,hfx,hpbl,fm,fh,qfx,regime,u10,ust,v10,wspd,znt !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'gz1oz0',gz1oz0) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) + call mpas_pool_get_array(diag_physics,'fm' ,fm ) + call mpas_pool_get_array(diag_physics,'fh' ,fh ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'regime',regime) + call mpas_pool_get_array(diag_physics,'u10' ,u10 ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) + call mpas_pool_get_array(diag_physics,'v10' ,v10 ) + call mpas_pool_get_array(diag_physics,'wspd' ,wspd ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + call mpas_pool_get_array(sfc_input ,'xland' ,xland ) + do j = jts,jte do i = its,ite !from surface-layer model: - br_p(i,j) = diag_physics % br % array(i) - gz1oz0_p(i,j) = diag_physics % gz1oz0 % array(i) - hfx_p(i,j) = diag_physics % hfx % array(i) - hpbl_p(i,j) = diag_physics % hpbl % array(i) - psim_p(i,j) = diag_physics % fm % array(i) - psih_p(i,j) = diag_physics % fh % array(i) - qfx_p(i,j) = diag_physics % qfx % array(i) - regime_p(i,j) = diag_physics % regime % array(i) - u10_p(i,j) = diag_physics % u10 % array(i) - ust_p(i,j) = diag_physics % ust % array(i) - v10_p(i,j) = diag_physics % v10 % array(i) - wspd_p(i,j) = diag_physics % wspd % array(i) - znt_p(i,j) = diag_physics % znt % array(i) - - xland_p(i,j) = sfc_input % xland % array(i) + br_p(i,j) = br(i) + gz1oz0_p(i,j) = gz1oz0(i) + hfx_p(i,j) = hfx(i) + hpbl_p(i,j) = hpbl(i) + psim_p(i,j) = fm(i) + psih_p(i,j) = fh(i) + qfx_p(i,j) = qfx(i) + regime_p(i,j) = regime(i) + u10_p(i,j) = u10(i) + ust_p(i,j) = ust(i) + v10_p(i,j) = v10(i) + wspd_p(i,j) = wspd(i) + znt_p(i,j) = znt(i) + + xland_p(i,j) = xland(i) !initialization for YSU PBL scheme: ctopo_p(i,j) = 1._RKIND ctopo2_p(i,j) = 1._RKIND @@ -185,32 +214,52 @@ subroutine pbl_to_MPAS(diag_physics,tend_physics) !================================================================================================== !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics + +!local pointers: + integer,dimension(:),pointer:: kpbl + real(kind=RKIND),dimension(:),pointer :: hpbl + real(kind=RKIND),dimension(:,:),pointer:: exch_h,kzh,kzm,kzq + real(kind=RKIND),dimension(:,:),pointer:: rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten !-------------------------------------------------------------------------------------------------- - + + call mpas_pool_get_array(diag_physics,'kpbl' ,kpbl ) + call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) + call mpas_pool_get_array(diag_physics,'exch_h',exch_h) + call mpas_pool_get_array(diag_physics,'kzh' ,kzh ) + call mpas_pool_get_array(diag_physics,'kzm' ,kzm ) + call mpas_pool_get_array(diag_physics,'kzq' ,kzq ) + + call mpas_pool_get_array(tend_physics,'rublten',rublten ) + call mpas_pool_get_array(tend_physics,'rvblten',rvblten ) + call mpas_pool_get_array(tend_physics,'rthblten',rthblten) + call mpas_pool_get_array(tend_physics,'rqvblten',rqvblten) + call mpas_pool_get_array(tend_physics,'rqcblten',rqcblten) + call mpas_pool_get_array(tend_physics,'rqiblten',rqiblten) + do j = jts,jte do i = its,ite - diag_physics % hpbl % array(i) = hpbl_p(i,j) - diag_physics % kpbl % array(i) = kpbl_p(i,j) + hpbl(i) = hpbl_p(i,j) + kpbl(i) = kpbl_p(i,j) enddo enddo do j = jts,jte do k = kts,kte do i = its,ite - diag_physics % exch_h % array(k,i) = exch_p(i,k,j) - tend_physics % rublten % array(k,i) = rublten_p(i,k,j) - tend_physics % rvblten % array(k,i) = rvblten_p(i,k,j) - tend_physics % rthblten % array(k,i) = rthblten_p(i,k,j) - tend_physics % rqvblten % array(k,i) = rqvblten_p(i,k,j) - tend_physics % rqcblten % array(k,i) = rqcblten_p(i,k,j) - tend_physics % rqiblten % array(k,i) = rqiblten_p(i,k,j) + exch_h(k,i) = exch_p(i,k,j) + rublten(k,i) = rublten_p(i,k,j) + rvblten(k,i) = rvblten_p(i,k,j) + rthblten(k,i) = rthblten_p(i,k,j) + rqvblten(k,i) = rqvblten_p(i,k,j) + rqcblten(k,i) = rqcblten_p(i,k,j) + rqiblten(k,i) = rqiblten_p(i,k,j) !temporary for debugging the YSU PBL scheme: - diag_physics % kzh % array(k,i) = kzh_p(i,k,j) - diag_physics % kzm % array(k,i) = kzm_p(i,k,j) - diag_physics % kzq % array(k,i) = kzq_p(i,k,j) + kzh(k,i) = kzh_p(i,k,j) + kzm(k,i) = kzm_p(i,k,j) + kzq(k,i) = kzq_p(i,k,j) enddo enddo enddo @@ -223,13 +272,13 @@ subroutine driver_pbl(sfc_input,diag_physics,tend_physics) !input and output arguments: !--------------------------- - type(sfc_input_type),intent(inout) :: sfc_input - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine driver_pbl: dt_pbl=',dt_pbl +! write(0,*) +! write(0,*) '--- enter subroutine driver_pbl: dt_pbl=',dt_pbl !copy MPAS arrays to local arrays: call pbl_from_MPAS(sfc_input,diag_physics) @@ -244,7 +293,7 @@ subroutine driver_pbl(sfc_input,diag_physics,tend_physics) qv3d = qv_p , qc3d = qc_p , qi3d = qi_p , & rublten = rublten_p , rvblten = rvblten_p , rthblten = rthblten_p , & rqvblten = rqvblten_p , rqcblten = rqcblten_p , rqiblten = rqiblten_p , & - flag_qi = f_qi , cp = cp , g = g , & + flag_qi = f_qi , cp = cp , g = gravity , & rovcp = rcp , rd = R_d , rovg = rdg , & ep1 = ep_1 , ep2 = ep_2 , karman = karman , & xlv = xlv , rv = R_v , znt = znt_p , & @@ -266,7 +315,7 @@ subroutine driver_pbl(sfc_input,diag_physics,tend_physics) !copy local arrays to MPAS grid: call pbl_to_MPAS(diag_physics,tend_physics) - write(0,*) '--- end subroutine driver_pbl' +! write(0,*) '--- end subroutine driver_pbl' end subroutine driver_pbl diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F index 6211446b57..8706f51dd6 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F @@ -7,7 +7,7 @@ ! !================================================================================================== module mpas_atmphys_driver_radiation_lw - use mpas_configure, only: config_do_restart, config_o3climatology + use mpas_kind_types use mpas_grid_types use mpas_timer @@ -61,14 +61,22 @@ module mpas_atmphys_driver_radiation_lw !> rrtmg_lw and camrad. !> Laura D. Fowler (birch.mmm,ucar.edu) / 2013-05-29. !> * added structure diag in the call to subroutine init_radiation_lw. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-01. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-01. !> * modified the call to subroutine rrtmg_lwrad to include the option of using the same ozone !> climatology as the one used in the CAM radiation codes. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-17. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-17. +!> * in call to subroutine rrtmg_lwrad, replaced the variable g (that originally pointed to +!> gravity) with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. contains + !================================================================================================== subroutine allocate_radiation_lw(xtime_s) !================================================================================================== @@ -234,39 +242,75 @@ subroutine deallocate_radiation_lw end subroutine deallocate_radiation_lw !================================================================================================== - subroutine radiation_lw_from_MPAS(xtime_s,mesh,state,diag_physics,atm_input,sfc_input) + subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physics,atm_input, & + sfc_input) !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh - type(state_type),intent(in):: state - type(atm_input_type) ,intent(in):: atm_input - type(sfc_input_type) ,intent(in):: sfc_input + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: atm_input + type(mpas_pool_type),intent(in):: sfc_input + + integer,intent(in):: time_lev + real(kind=RKIND),intent(in):: xtime_s !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics - real(kind=RKIND),intent(in):: xtime_s +!local pointers: + logical,pointer:: config_o3climatology -!local variables: + real(kind=RKIND),dimension(:),pointer :: latCell,lonCell + real(kind=RKIND),dimension(:),pointer :: skintemp,snow,xice,xland + real(kind=RKIND),dimension(:),pointer :: m_ps,pin + real(kind=RKIND),dimension(:),pointer :: sfc_albedo,sfc_emiss + real(kind=RKIND),dimension(:,:),pointer :: cldfrac,m_hybi,o3clim,o3vmr + real(kind=RKIND),dimension(:,:,:),pointer:: aerosols,ozmixm + +!local variables and arrays: integer:: ncols,nlevs real(kind=RKIND),dimension(:,:),allocatable:: p2d,o32d !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + + call mpas_pool_get_array(mesh,'latCell',latCell) + call mpas_pool_get_array(mesh,'lonCell',lonCell) + call mpas_pool_get_array(mesh,'m_hybi' ,m_hybi ) + + call mpas_pool_get_array(state,'m_ps' ,m_ps ,time_lev) + call mpas_pool_get_array(state,'aerosols',aerosols,time_lev) + + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + + call mpas_pool_get_array(atm_input,'pin' ,pin ) + call mpas_pool_get_array(atm_input,'ozmixm' ,ozmixm ) + + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'cldfrac' ,cldfrac ) + call mpas_pool_get_array(diag_physics,'o3clim' ,o3clim ) + call mpas_pool_get_array(diag_physics,'o3vmr' ,o3vmr ) + do j = jts,jte do i = its,ite - sfc_emiss_p(i,j) = diag_physics % sfc_emiss % array(i) - tsk_p(i,j) = sfc_input % skintemp % array(i) - snow_p(i,j) = sfc_input % snow % array(i) - xice_p(i,j) = sfc_input % xice % array(i) - xland_p(i,j) = sfc_input % xland % array(i) + sfc_emiss_p(i,j) = sfc_emiss(i) + tsk_p(i,j) = skintemp(i) + snow_p(i,j) = snow(i) + xice_p(i,j) = xice(i) + xland_p(i,j) = xland(i) enddo enddo do j = jts,jte do k = kts,kte do i = its,ite - cldfrac_p(i,k,j) = diag_physics % cldfrac % array(k,i) + cldfrac_p(i,k,j) = cldfrac(k,i) enddo enddo enddo @@ -320,12 +364,12 @@ subroutine radiation_lw_from_MPAS(xtime_s,mesh,state,diag_physics,atm_input,sfc_ if(config_o3climatology) then !ozone mixing ratio: do k = 1, num_oznLevels - pin_p(k) = atm_input % pin % array(k) + pin_p(k) = pin(k) enddo do j = jts,jte do k = 1, num_oznLevels do i = its,ite - o3clim_p(i,k,j) = diag_physics % o3clim % array(k,i) + o3clim_p(i,k,j) = o3clim(k,i) enddo enddo enddo @@ -344,7 +388,7 @@ subroutine radiation_lw_from_MPAS(xtime_s,mesh,state,diag_physics,atm_input,sfc_ call vinterp_ozn(1,ncols,ncols,nlevs,p2d,pin_p,num_oznlevels,o3clim_p(1,1,j),o32d) do i = its,ite do k = kts,kte - diag_physics % o3vmr % array(k,i) = o32d(i,k) + o3vmr(k,i) = o32d(i,k) enddo enddo enddo @@ -365,9 +409,9 @@ subroutine radiation_lw_from_MPAS(xtime_s,mesh,state,diag_physics,atm_input,sfc_ case("cam_lw") do j = jts,jte do i = its,ite - xlat_p(i,j) = (mesh % latCell % array(i)) / degrad - xlon_p(i,j) = (mesh % lonCell % array(i)) / degrad - sfc_albedo_p(i,j) = diag_physics % sfc_albedo % array(i) + xlat_p(i,j) = latCell(i) / degrad + xlon_p(i,j) = lonCell(i) / degrad + sfc_albedo_p(i,j) = sfc_albedo(i) coszr_p(i,j) = 0.0_RKIND gsw_p(i,j) = 0.0_RKIND @@ -423,33 +467,33 @@ subroutine radiation_lw_from_MPAS(xtime_s,mesh,state,diag_physics,atm_input,sfc_ call mpas_timer_start("CAM lw: ozone and aerosols") !ozone mixing ratio: do k = 1, num_oznlevels - pin_p(k) = atm_input % pin % array(k) + pin_p(k) = pin(k) enddo do n = 1, num_months do j = jts,jte do k = 1, num_oznlevels do i = its,ite - ozmixm_p(i,k,j,n) = atm_input % ozmixm % array(n,k,i) + ozmixm_p(i,k,j,n) = ozmixm(n,k,i) enddo enddo enddo enddo !aerosol mixing ratio: do k = 1, num_aerlevels - m_hybi_p(k) = mesh % m_hybi % array(k,1) + m_hybi_p(k) = m_hybi(k,1) enddo do i = its,ite do j = jts,jte - m_psp_p(i,j) = state % m_ps % array(i) - m_psn_p(i,j) = state % m_ps % array(i) + m_psp_p(i,j) = m_ps(i) + m_psn_p(i,j) = m_ps(i) enddo enddo do n = 1,num_aerosols do j = jts,jte do k = 1, num_aerlevels do i = its,ite - aerosolcp_p(i,k,j,n) = state % aerosols % array(n,k,i) - aerosolcn_p(i,k,j,n) = state % aerosols % array(n,k,i) + aerosolcp_p(i,k,j,n) = aerosols(n,k,i) + aerosolcn_p(i,k,j,n) = aerosols(n,k,i) enddo enddo enddo @@ -471,33 +515,52 @@ subroutine radiation_lw_to_MPAS(diag_physics,tend_physics) !================================================================================================== !input arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics -!local variables: +!local pointers: + real(kind=RKIND),dimension(:),pointer :: glw,lwcf,lwdnb,lwdnbc,lwdnt,lwdntc,lwupb,lwupbc, & + lwupt,lwuptc,olrtoa + real(kind=RKIND),dimension(:,:),pointer:: rthratenlw + +!local variables and arrays: integer:: nlay,pcols real(kind=RKIND),dimension(:,:),allocatable:: p1d !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'lwcf' ,lwcf ) + call mpas_pool_get_array(diag_physics,'lwdnb' ,lwdnb ) + call mpas_pool_get_array(diag_physics,'lwdnbc',lwdnbc) + call mpas_pool_get_array(diag_physics,'lwdnt' ,lwdnt ) + call mpas_pool_get_array(diag_physics,'lwdntc',lwdntc) + call mpas_pool_get_array(diag_physics,'lwupb' ,lwupb ) + call mpas_pool_get_array(diag_physics,'lwupbc',lwupbc) + call mpas_pool_get_array(diag_physics,'lwupt' ,lwupt ) + call mpas_pool_get_array(diag_physics,'lwuptc',lwuptc) + call mpas_pool_get_array(diag_physics,'olrtoa',olrtoa) + + call mpas_pool_get_array(tend_physics,'rthratenlw',rthratenlw) + do j = jts,jte do i = its,ite - diag_physics % glw % array(i) = glw_p(i,j) - diag_physics % lwcf % array(i) = lwcf_p(i,j) - diag_physics % lwdnb % array(i) = lwdnb_p(i,j) - diag_physics % lwdnbc % array(i) = lwdnbc_p(i,j) - diag_physics % lwdnt % array(i) = lwdnt_p(i,j) - diag_physics % lwdntc % array(i) = lwdntc_p(i,j) - diag_physics % lwupb % array(i) = lwupb_p(i,j) - diag_physics % lwupbc % array(i) = lwupbc_p(i,j) - diag_physics % lwupt % array(i) = lwupt_p(i,j) - diag_physics % lwuptc % array(i) = lwuptc_p(i,j) - diag_physics % olrtoa % array(i) = olrtoa_p(i,j) + glw(i) = glw_p(i,j) + lwcf(i) = lwcf_p(i,j) + lwdnb(i) = lwdnb_p(i,j) + lwdnbc(i) = lwdnbc_p(i,j) + lwdnt(i) = lwdnt_p(i,j) + lwdntc(i) = lwdntc_p(i,j) + lwupb(i) = lwupb_p(i,j) + lwupbc(i) = lwupbc_p(i,j) + lwupt(i) = lwupt_p(i,j) + lwuptc(i) = lwuptc_p(i,j) + olrtoa(i) = olrtoa_p(i,j) enddo do k = kts,kte do i = its,ite - tend_physics % rthratenlw % array(k,i) = rthratenlw_p(i,k,j) + rthratenlw(k,i) = rthratenlw_p(i,k,j) enddo enddo enddo @@ -509,29 +572,37 @@ subroutine radiation_camlw_to_MPAS(diag_physics) !================================================================================================== !input arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + real(kind=RKIND),dimension(:,:),pointer :: emstot + real(kind=RKIND),dimension(:,:,:),pointer:: absnxt,abstot !--------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'absnxt',absnxt) + call mpas_pool_get_array(diag_physics,'abstot',abstot) + call mpas_pool_get_array(diag_physics,'emstot',emstot) + !write(0,*) '--- writing absnxt,abstot,and emstot to restart =', l_camlw do j = jts,jte do n = 1,cam_abs_dim1 do k = kts,kte do i = its,ite - diag_physics % absnxt % array(k,n,i) = absnxt_p(i,k,n,j) + absnxt(k,n,i) = absnxt_p(i,k,n,j) enddo enddo enddo do n = 1,cam_abs_dim2 do k = kts,kte+1 do i = its,ite - diag_physics % abstot % array(k,n,i) = abstot_p(i,k,n,j) + abstot(k,n,i) = abstot_p(i,k,n,j) enddo enddo enddo do k = kts,kte+1 do i = its,ite - diag_physics % emstot % array(k,i) = emstot_p(i,k,j) + emstot(k,i) = emstot_p(i,k,j) enddo enddo enddo @@ -539,55 +610,64 @@ subroutine radiation_camlw_to_MPAS(diag_physics) end subroutine radiation_camlw_to_MPAS !================================================================================================== - subroutine init_radiation_lw(dminfo,mesh,atm_input,diag,state_1,state_2) + subroutine init_radiation_lw(dminfo,mesh,atm_input,diag,state,time_lev) !================================================================================================== !input arguments: type(dm_info),intent(in):: dminfo - type(mesh_type),intent(in),optional:: mesh - type(diag_type),intent(in),optional:: diag + type(mpas_pool_type),intent(in),optional:: mesh + type(mpas_pool_type),intent(in),optional:: diag + + integer,intent(in),optional:: time_lev !inout arguments: - type(atm_input_type),intent(inout),optional:: atm_input - type(state_type),intent(inout),optional:: state_1,state_2 + type(mpas_pool_type),intent(inout),optional:: atm_input + type(mpas_pool_type),intent(inout),optional:: state !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter radiation_lw initialization:' +! write(0,*) +! write(0,*) '--- enter radiation_lw initialization:' radiation_lw_select: select case (trim(radt_lw_scheme)) case ("rrtmg_lw") - write(0,*) ' enter subroutine rrtmg_lwinit:' +! write(0,*) ' enter subroutine rrtmg_lwinit:' call rrtmg_initlw_forMPAS(dminfo) - write(0,*) ' end subroutine rrtmg_lwinit' +! write(0,*) ' end subroutine rrtmg_lwinit' case("cam_lw") - write(0,*) ' enter subroutine camradinit:' - call camradinit(dminfo,mesh,atm_input,diag,state_1,state_2) - write(0,*) ' end subroutine camradinit' +! write(0,*) ' enter subroutine camradinit:' + call camradinit(dminfo,mesh,atm_input,diag,state,time_lev) +! write(0,*) ' end subroutine camradinit' case default end select radiation_lw_select - write(0,*) '--- end radiation_lw initialization' +! write(0,*) '--- end radiation_lw initialization' end subroutine init_radiation_lw !================================================================================================== - subroutine driver_radiation_lw(xtime_s,mesh,state,diag_physics,atm_input,sfc_input,tend_physics) + subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics,atm_input, & + sfc_input,tend_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + + integer,intent(in):: time_lev real(kind=RKIND),intent(in):: xtime_s !inout arguments: - type(state_type) ,intent(inout):: state - type(diag_physics_type),intent(inout):: diag_physics - type(atm_input_type) ,intent(inout):: atm_input - type(sfc_input_type) ,intent(inout):: sfc_input - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: state + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: atm_input + type(mpas_pool_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: tend_physics + +!local pointers: + logical,pointer:: config_o3climatology !local variables: integer:: o3input @@ -595,20 +675,22 @@ subroutine driver_radiation_lw(xtime_s,mesh,state,diag_physics,atm_input,sfc_inp !-------------------------------------------------------------------------------------------------- call mpas_timer_start("radiation_lw") - write(0,100) +! write(0,100) !formats: 100 format(/,' --- enter subroutine driver_radiation_lw: ',i6) 101 format(i8,12(1x,e15.8)) + call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + !copy MPAS arrays to local arrays: - call radiation_lw_from_MPAS(xtime_s,mesh,state,diag_physics,atm_input,sfc_input) + call radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physics,atm_input,sfc_input) !call to longwave radiation scheme: radiation_lw_select: select case (trim(radt_lw_scheme)) case ("rrtmg_lw") - write(0,*) '--- enter subroutine rrtmg_lwrad:' +! write(0,*) '--- enter subroutine rrtmg_lwrad:' o3input = 0 if(config_o3climatology) o3input = 2 @@ -620,7 +702,7 @@ subroutine driver_radiation_lw(xtime_s,mesh,state,diag_physics,atm_input,sfc_inp lwupbc = lwupbc_p , lwdnb = lwdnb_p , lwdnbc = lwdnbc_p ,& lwcf = lwcf_p , glw = glw_p , olr = olrtoa_p ,& emiss = sfc_emiss_p , tsk = tsk_p , dz8w = dz_p ,& - cldfra3d = cldfrac_p , r = R_d , g = g ,& + cldfra3d = cldfrac_p , r = R_d , g = gravity ,& icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice ,& f_rain_phy = f_rain , xland = xland_p , xice = xice_p ,& snow = snow_p , qv3d = qv_p , qc3d = qc_p ,& @@ -633,6 +715,7 @@ subroutine driver_radiation_lw(xtime_s,mesh,state,diag_physics,atm_input,sfc_inp ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme ,& its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) +! write(0,*) '--- exit subroutine rrtmg_lwrad' case ("cam_lw") xtime_m = xtime_s/60. @@ -644,7 +727,7 @@ subroutine driver_radiation_lw(xtime_s,mesh,state,diag_physics,atm_input,sfc_inp radt = dt_radtlw/60. call mpas_timer_start("camrad") - write(0,*) '--- enter subroutine camrad_lw: doabsems=',doabsems +! write(0,*) '--- enter subroutine camrad_lw: doabsems=',doabsems call camrad( dolw = .true. , dosw = .false. , & p_phy = pres_hyd_p , p8w = pres2_hyd_p , & pi_phy = pi_p , t_phy = t_p , & @@ -701,7 +784,7 @@ subroutine driver_radiation_lw(xtime_s,mesh,state,diag_physics,atm_input,sfc_inp !copy local arrays to MPAS grid: call radiation_lw_to_MPAS(diag_physics,tend_physics) - write(0,*) '--- end subroutine driver_radiation_lw' +! write(0,*) '--- end subroutine driver_radiation_lw' call mpas_timer_stop("radiation_lw") !formats: diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index 6b0448da7e..d77a481d7d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -7,7 +7,7 @@ ! !================================================================================================== module mpas_atmphys_driver_radiation_sw - use mpas_configure + use mpas_kind_types use mpas_grid_types use mpas_timer @@ -56,17 +56,25 @@ module mpas_atmphys_driver_radiation_sw !> ---------------------------------------- !> * removed the pre-processor option "do_hydrostatic_pressure" before call to subroutines !> rrtmg_sw and camrad. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-05-29. +!> Laura D. Fowler (laura@ucar.edu) / 2013-05-29. !> * added structure diag in the call to subroutine init_radiation_sw and call to subroutine !> camradinit for initialization of variable mxaerl. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-01. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-01. !> * modified the call to subroutine rrtmg_swrad to include the option of using the same ozone !> climatology as the one used in the CAM radiation codes. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-17. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-17. +!> * in call to subroutine rrtmg_swrad, replaced the variable g (that originally pointed to +!> gravity) with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. contains + !================================================================================================== subroutine allocate_radiation_sw(xtime_s) !================================================================================================== @@ -251,36 +259,71 @@ subroutine deallocate_radiation_sw end subroutine deallocate_radiation_sw !================================================================================================== - subroutine radiation_sw_from_MPAS(mesh,state,diag_physics,atm_input,sfc_input,xtime_s) + subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_input, & + sfc_input,xtime_s) !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh - type(state_type),intent(in):: state - type(diag_physics_type),intent(in):: diag_physics - type(atm_input_type) ,intent(in):: atm_input - type(sfc_input_type) ,intent(in):: sfc_input - + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: atm_input + type(mpas_pool_type),intent(in):: sfc_input + + integer,intent(in):: time_lev real(kind=RKIND),intent(in):: xtime_s +!local pointers: + logical,pointer:: config_o3climatology + + real(kind=RKIND),dimension(:),pointer :: latCell,lonCell + real(kind=RKIND),dimension(:),pointer :: skintemp,snow,xice,xland + real(kind=RKIND),dimension(:),pointer :: m_ps,pin + real(kind=RKIND),dimension(:),pointer :: sfc_albedo,sfc_emiss + real(kind=RKIND),dimension(:,:),pointer :: cldfrac,m_hybi,o3clim + real(kind=RKIND),dimension(:,:,:),pointer:: aerosols,ozmixm + !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + + call mpas_pool_get_array(mesh,'latCell',latCell) + call mpas_pool_get_array(mesh,'lonCell',lonCell) + call mpas_pool_get_array(mesh,'m_hybi' ,m_hybi ) + + call mpas_pool_get_array(state,'m_ps' ,m_ps ,time_lev) + call mpas_pool_get_array(state,'aerosols',aerosols,time_lev) + + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + + call mpas_pool_get_array(atm_input,'pin' ,pin ) + call mpas_pool_get_array(atm_input,'ozmixm' ,ozmixm ) + + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'cldfrac' ,cldfrac ) + call mpas_pool_get_array(diag_physics,'o3clim' ,o3clim ) + do j = jts,jte do i = its,ite - xlat_p(i,j) = (mesh % latCell % array(i)) / degrad - xlon_p(i,j) = (mesh % lonCell % array(i)) / degrad - - sfc_albedo_p(i,j) = diag_physics % sfc_albedo % array(i) - snow_p(i,j) = sfc_input % snow % array(i) - tsk_p(i,j) = sfc_input % skintemp % array(i) - xice_p(i,j) = sfc_input % xice % array(i) - xland_p(i,j) = sfc_input % xland % array(i) + xlat_p(i,j) = latCell(i) / degrad + xlon_p(i,j) = lonCell(i) / degrad + + sfc_albedo_p(i,j) = sfc_albedo(i) + snow_p(i,j) = snow(i) + tsk_p(i,j) = skintemp(i) + xice_p(i,j) = xice(i) + xland_p(i,j) = xland(i) enddo enddo do j = jts,jte do k = kts,kte do i = its,ite - cldfrac_p(i,k,j) = diag_physics % cldfrac % array(k,i) + cldfrac_p(i,k,j) = cldfrac(k,i) enddo enddo enddo @@ -334,12 +377,12 @@ subroutine radiation_sw_from_MPAS(mesh,state,diag_physics,atm_input,sfc_input,xt !ozone volum mixing ratio: if(config_o3climatology) then do k = 1, num_oznLevels - pin_p(k) = atm_input % pin % array(k) + pin_p(k) = pin(k) enddo do j = jts,jte do k = 1, num_oznLevels do i = its,ite - o3clim_p(i,k,j) = diag_physics % o3clim % array(k,i) + o3clim_p(i,k,j) = o3clim(k,i) enddo enddo enddo @@ -359,7 +402,7 @@ subroutine radiation_sw_from_MPAS(mesh,state,diag_physics,atm_input,sfc_input,xt case("cam_sw") do j = jts,jte do i = its,ite - sfc_emiss_p(i,j) = diag_physics % sfc_emiss % array(i) + sfc_emiss_p(i,j) = sfc_emiss(i) olrtoa_p(i,j) = 0.0_RKIND glw_p(i,j) = 0.0_RKIND @@ -408,33 +451,33 @@ subroutine radiation_sw_from_MPAS(mesh,state,diag_physics,atm_input,sfc_input,xt endif !ozone mixing ratio: do k = 1, num_oznlevels - pin_p(k) = atm_input % pin % array(k) + pin_p(k) = pin(k) enddo do n = 1, num_months do j = jts,jte do k = 1, num_oznlevels do i = its,ite - ozmixm_p(i,k,j,n) = atm_input % ozmixm % array(n,k,i) + ozmixm_p(i,k,j,n) = ozmixm(n,k,i) enddo enddo enddo enddo !aerosol mixing ratio: do k = 1, num_aerlevels - m_hybi_p(k) = mesh % m_hybi % array(k,1) + m_hybi_p(k) = m_hybi(k,1) enddo do i = its,ite do j = jts,jte - m_psp_p(i,j) = state % m_ps % array(i) - m_psn_p(i,j) = state % m_ps % array(i) + m_psp_p(i,j) = m_ps(i) + m_psn_p(i,j) = m_ps(i) enddo enddo do n = 1,num_aerosols do j = jts,jte do k = 1, num_aerlevels do i = its,ite - aerosolcp_p(i,k,j,n) = state % aerosols % array(n,k,i) - aerosolcn_p(i,k,j,n) = state % aerosols % array(n,k,i) + aerosolcp_p(i,k,j,n) = aerosols(n,k,i) + aerosolcn_p(i,k,j,n) = aerosols(n,k,i) enddo enddo enddo @@ -455,39 +498,62 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics) !================================================================================================== !input arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics + +!local pointers: + real(kind=RKIND),dimension(:),pointer :: coszr,gsw,swcf,swdnb,swdnbc,swdnt,swdntc, & + swupb,swupbc,swupt,swuptc +!real(kind=RKIND),dimension(:,:),pointer:: swdnflx,swdnflxc,swupflx,swupflxc + real(kind=RKIND),dimension(:,:),pointer:: rthratensw !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'coszr' ,coszr ) + call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) + call mpas_pool_get_array(diag_physics,'swcf' ,swcf ) + call mpas_pool_get_array(diag_physics,'swdnb' ,swdnb ) + call mpas_pool_get_array(diag_physics,'swdnbc' ,swdnbc ) + call mpas_pool_get_array(diag_physics,'swdnt' ,swdnt ) + call mpas_pool_get_array(diag_physics,'swdntc' ,swdntc ) + call mpas_pool_get_array(diag_physics,'swupb' ,swupb ) + call mpas_pool_get_array(diag_physics,'swupbc' , swupbc ) + call mpas_pool_get_array(diag_physics,'swupt' ,swupt ) + call mpas_pool_get_array(diag_physics,'swuptc' ,swuptc ) +!call mpas_pool_get_array(diag_physics,'swdnflx' ,swdnflx ) +!call mpas_pool_get_array(diag_physics,'swdnflxc' ,swdnflxc ) +!call mpas_pool_get_array(diag_physics,'swupflx' ,swupflx ) +!call mpas_pool_get_array(diag_physics,'swupflxc' ,swupflxc ) + call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) + do j = jts,jte do i = its,ite - diag_physics % coszr % array(i) = coszr_p(i,j) - diag_physics % gsw % array(i) = gsw_p(i,j) - diag_physics % swcf % array(i) = swcf_p(i,j) - diag_physics % swdnb % array(i) = swdnb_p(i,j) - diag_physics % swdnbc % array(i) = swdnbc_p(i,j) - diag_physics % swdnt % array(i) = swdnt_p(i,j) - diag_physics % swdntc % array(i) = swdntc_p(i,j) - diag_physics % swupb % array(i) = swupb_p(i,j) - diag_physics % swupbc % array(i) = swupbc_p(i,j) - diag_physics % swupt % array(i) = swupt_p(i,j) - diag_physics % swuptc % array(i) = swuptc_p(i,j) + coszr(i) = coszr_p(i,j) + gsw(i) = gsw_p(i,j) + swcf(i) = swcf_p(i,j) + swdnb(i) = swdnb_p(i,j) + swdnbc(i) = swdnbc_p(i,j) + swdnt(i) = swdnt_p(i,j) + swdntc(i) = swdntc_p(i,j) + swupb(i) = swupb_p(i,j) + swupbc(i) = swupbc_p(i,j) + swupt(i) = swupt_p(i,j) + swuptc(i) = swuptc_p(i,j) enddo !not needed: !do k = kts,kte+2 !do i = its,ite -! diag_physics % swdnflx % array(k,i) = swdnflx_p(i,k,j) -! diag_physics % swdnflxc % array(k,i) = swdnflxc_p(i,k,j) -! diag_physics % swupflx % array(k,i) = swupflx_p(i,k,j) -! diag_physics % swupflxc % array(k,i) = swupflxc_p(i,k,j) +! swdnflx(k,i) = swdnflx_p(i,k,j) +! swdnflxc(k,i) = swdnflxc_p(i,k,j) +! swupflx(k,i) = swupflx_p(i,k,j) +! swupflxc(k,i) = swupflxc_p(i,k,j) !enddo !enddo do k = kts,kte do i = its,ite - tend_physics % rthratensw % array(k,i) = rthratensw_p(i,k,j) + rthratensw(k,i) = rthratensw_p(i,k,j) enddo enddo @@ -496,66 +562,77 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics) end subroutine radiation_sw_to_MPAS !================================================================================================== - subroutine init_radiation_sw(dminfo,mesh,atm_input,diag,state_1,state_2) + subroutine init_radiation_sw(dminfo,mesh,atm_input,diag,state,time_lev) !================================================================================================== !input arguments: type(dm_info), intent(in):: dminfo - type(mesh_type),intent(in),optional :: mesh - type(diag_type),intent(in),optional :: diag + type(mpas_pool_type),intent(in),optional:: mesh + type(mpas_pool_type),intent(in),optional:: diag + + integer,intent(in),optional:: time_lev !inout arguments: - type(atm_input_type),intent(inout),optional:: atm_input - type(state_type),intent(inout),optional:: state_1,state_2 + type(mpas_pool_type),intent(inout),optional:: atm_input + type(mpas_pool_type),intent(inout),optional:: state !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter radiation_sw initialization:' +! write(0,*) +! write(0,*) '--- enter radiation_sw initialization:' !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) case ("rrtmg_sw") - write(0,*) ' enter subroutine rrtmg_swinit:' +! write(0,*) ' enter subroutine rrtmg_swinit:' call rrtmg_initsw_forMPAS(dminfo) - write(0,*) ' end subroutine rrtmg_swinit' +! write(0,*) ' end subroutine rrtmg_swinit' case("cam_sw") - write(0,*) ' enter subroutine camradinit:' - call camradinit(dminfo,mesh,atm_input,diag,state_1,state_2) - write(0,*) ' end subroutine camradinit' +! write(0,*) ' enter subroutine camradinit:' + call camradinit(dminfo,mesh,atm_input,diag,state,time_lev) +! write(0,*) ' end subroutine camradinit' case default end select radiation_sw_select - write(0,*) '--- end radiation_sw initialization' +! write(0,*) '--- end radiation_sw initialization' end subroutine init_radiation_sw !================================================================================================== - subroutine driver_radiation_sw(itimestep,mesh,state,diag_physics,atm_input,sfc_input, & - tend_physics,xtime_s) + subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physics,atm_input, & + sfc_input,tend_physics,xtime_s) !================================================================================================== !input arguments: integer,intent(in):: itimestep - type(mesh_type),intent(in) :: mesh + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + + integer,intent(in):: time_lev real(kind=RKIND),intent(in):: xtime_s !inout arguments: - type(state_type) ,intent(inout):: state - type(diag_physics_type),intent(inout):: diag_physics - type(atm_input_type) ,intent(inout):: atm_input - type(sfc_input_type) ,intent(inout):: sfc_input - type(tend_physics_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: state + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: atm_input + type(mpas_pool_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: tend_physics + + +!local pointers: + logical,pointer:: config_o3climatology !local variables: integer:: o3input real(kind=RKIND):: radt,xtime_m !-------------------------------------------------------------------------------------------------- - write(0,100) itimestep +! write(0,100) itimestep + + call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) !formats: 100 format(/,' --- enter subroutine driver_radiation_sw: ',i6) @@ -571,12 +648,12 @@ subroutine driver_radiation_sw(itimestep,mesh,state,diag_physics,atm_input,sfc_i xtime_m = xtime_s/60. !copy MPAS arrays to local arrays: - call radiation_sw_from_MPAS(mesh,state,diag_physics,atm_input,sfc_input,xtime_s) + call radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_input,sfc_input,xtime_s) !... calculates solar declination: !call radconst(declin,solcon,julday,degrad,dpd) call radconst(declin,solcon,curr_julday,degrad,dpd) - write(0,101) itimestep,year,julday,gmt,xtime_m,curr_julday,solcon,declin +! write(0,101) itimestep,year,julday,gmt,xtime_m,curr_julday,solcon,declin !... convert the radiation time_step to minutes: radt = dt_radtsw/60. @@ -586,7 +663,7 @@ subroutine driver_radiation_sw(itimestep,mesh,state,diag_physics,atm_input,sfc_i case ("rrtmg_sw") - write(0,*) '--- enter subroutine rrtmg_swrad:' +! write(0,*) '--- enter subroutine rrtmg_swrad:' o3input = 0 if(config_o3climatology) o3input = 2 @@ -601,7 +678,7 @@ subroutine driver_radiation_sw(itimestep,mesh,state,diag_physics,atm_input,sfc_i radt = radt , degrad = degrad , declin = declin ,& coszr = coszr_p , julday = julday , solcon = solcon ,& albedo = sfc_albedo_p , tsk = tsk_p , dz8w = dz_p ,& - cldfra3d = cldfrac_p , r = R_d , g = g ,& + cldfra3d = cldfrac_p , r = R_d , g = gravity ,& icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice ,& f_rain_phy = f_rain , xland = xland_p , xice = xice_p ,& snow = snow_p , qv3d = qv_p , qc3d = qc_p ,& @@ -618,11 +695,11 @@ subroutine driver_radiation_sw(itimestep,mesh,state,diag_physics,atm_input,sfc_i ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme ,& its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - write(0,*) '--- exit subroutine rrtmg_swrad' +! write(0,*) '--- exit subroutine rrtmg_swrad' case ("cam_sw") - write(0,*) '--- enter subroutine camrad_sw:' +! write(0,*) '--- enter subroutine camrad_sw:' call camrad( dolw = .false. , dosw = .true. , & p_phy = pres_hyd_p , p8w = pres2_hyd_p , & pi_phy = pi_p , t_phy = t_p , & @@ -679,7 +756,7 @@ subroutine driver_radiation_sw(itimestep,mesh,state,diag_physics,atm_input,sfc_i !copy local arrays to MPAS grid: call radiation_sw_to_MPAS(diag_physics,tend_physics) - write(0,*) '--- end subroutine driver_radiation_sw' +! write(0,*) '--- end subroutine driver_radiation_sw' !formats: 200 format(i3,i6,8(1x,e15.8)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index 1ded3279c5..1008b2f336 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -7,6 +7,7 @@ ! !================================================================================================== module mpas_atmphys_driver_sfclayer + use mpas_kind_types use mpas_grid_types use mpas_atmphys_constants @@ -54,14 +55,29 @@ module mpas_atmphys_driver_sfclayer !> ---------------------------------------- !> * removed the pre-processor option "do_hydrostatic_pressure" before call to the subroutine !> sfclay. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-05-29. +!> Laura D. Fowler (laura@ucar.edu) / 2013-05-29. !> * updated the definition of the horizontal resolution to the actual mean distance between !> cell centers. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-23. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-23. +!> * in call to subroutine sfclay, replaced the variable g (that originally pointed to gravity) +!> with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * in subroutine sfclayer_from_MPAS, added initialization of ustm, cd, cda, ck, and cka. in +!> subroutine sfclayer_to_MPAS, filled diag_physics%ustm with ustm_p after call to subroutine +!> sfclay. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-16. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * added initialization of local logical "allowed_to read" in subroutine init_sfclayer. This +!> logical is actually not used in subroutine sfclayinit. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-25. contains + !================================================================================================== subroutine allocate_sfclayer !================================================================================================== @@ -159,46 +175,90 @@ subroutine sfclayer_from_MPAS(mesh,diag_physics,sfc_input) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(sfc_input_type),intent(in):: sfc_input - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + real(kind=RKIND),dimension(:),pointer:: skintemp,xland + real(kind=RKIND),dimension(:),pointer:: dcEdge_m,hpbl,mavail + real(kind=RKIND),dimension(:),pointer:: br,cpm,chs,chs2,cqs2,fh,fm,flhc,flqc,gz1oz0,hfx, & + qfx,qgh,qsfc,lh,mol,psim,psih,regime,rmol,ust,ustm, & + wspd,znt,zol !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(sfc_input ,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input ,'xland' ,xland ) + call mpas_pool_get_array(diag_physics,'dcEdge_m',dcEdge_m) + call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) + call mpas_pool_get_array(diag_physics,'mavail' ,mavail ) + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) + call mpas_pool_get_array(diag_physics,'chs' ,chs ) + call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) + call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) + call mpas_pool_get_array(diag_physics,'fh' ,fh ) + call mpas_pool_get_array(diag_physics,'fm' ,fm ) + call mpas_pool_get_array(diag_physics,'flhc' ,flhc ) + call mpas_pool_get_array(diag_physics,'flqc' ,flqc ) + call mpas_pool_get_array(diag_physics,'gz1oz0' ,gz1oz0 ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'mol' ,mol ) + call mpas_pool_get_array(diag_physics,'psim' ,psim ) + call mpas_pool_get_array(diag_physics,'psih' ,psih ) + call mpas_pool_get_array(diag_physics,'regime' ,regime ) + call mpas_pool_get_array(diag_physics,'rmol' ,rmol ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) + call mpas_pool_get_array(diag_physics,'ustm' ,ustm ) + call mpas_pool_get_array(diag_physics,'wspd' ,wspd ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + call mpas_pool_get_array(diag_physics,'zol' ,zol ) + do j = jts,jte do i = its,ite !input variables: - dx_p(i,j) = diag_physics % dcEdge_m % array(i) - hpbl_p(i,j) = diag_physics % hpbl % array(i) - mavail_p(i,j) = diag_physics % mavail % array(i) - tsk_p(i,j) = sfc_input % skintemp % array(i) - xland_p(i,j) = sfc_input % xland % array(i) + dx_p(i,j) = dcEdge_m(i) + hpbl_p(i,j) = hpbl(i) + mavail_p(i,j) = mavail(i) + tsk_p(i,j) = skintemp(i) + xland_p(i,j) = xland(i) !inout variables: - br_p(i,j) = diag_physics % br % array(i) - cpm_p(i,j) = diag_physics % cpm % array(i) - chs_p(i,j) = diag_physics % chs % array(i) - chs2_p(i,j) = diag_physics % chs2 % array(i) - cqs2_p(i,j) = diag_physics % cqs2 % array(i) - fh_p(i,j) = diag_physics % fh % array(i) - fm_p(i,j) = diag_physics % fm % array(i) - flhc_p(i,j) = diag_physics % flhc % array(i) - flqc_p(i,j) = diag_physics % flqc % array(i) - gz1oz0_p(i,j) = diag_physics % gz1oz0 % array(i) - hfx_p(i,j) = diag_physics % hfx % array(i) - qfx_p(i,j) = diag_physics % qfx % array(i) - qgh_p(i,j) = diag_physics % qgh % array(i) - qsfc_p(i,j) = diag_physics % qsfc % array(i) - lh_p(i,j) = diag_physics % lh % array(i) - mol_p(i,j) = diag_physics % mol % array(i) - psim_p(i,j) = diag_physics % psim % array(i) - psih_p(i,j) = diag_physics % psih % array(i) - regime_p(i,j) = diag_physics % regime % array(i) - rmol_p(i,j) = diag_physics % rmol % array(i) - ust_p(i,j) = diag_physics % ust % array(i) - wspd_p(i,j) = diag_physics % wspd % array(i) - znt_p(i,j) = diag_physics % znt % array(i) - zol_p(i,j) = diag_physics % zol % array(i) + br_p(i,j) = br(i) + cpm_p(i,j) = cpm(i) + chs_p(i,j) = chs(i) + chs2_p(i,j) = chs2(i) + cqs2_p(i,j) = cqs2(i) + fh_p(i,j) = fh(i) + fm_p(i,j) = fm(i) + flhc_p(i,j) = flhc(i) + flqc_p(i,j) = flqc(i) + gz1oz0_p(i,j) = gz1oz0(i) + hfx_p(i,j) = hfx(i) + qfx_p(i,j) = qfx(i) + qgh_p(i,j) = qgh(i) + qsfc_p(i,j) = qsfc(i) + lh_p(i,j) = lh(i) + mol_p(i,j) = mol(i) + psim_p(i,j) = psim(i) + psih_p(i,j) = psih(i) + regime_p(i,j) = regime(i) + rmol_p(i,j) = rmol(i) + ust_p(i,j) = ust(i) + ustm_p(i,j) = ustm(i) + wspd_p(i,j) = wspd(i) + znt_p(i,j) = znt(i) + zol_p(i,j) = zol(i) !output variables: + cd_p(i,j) = 0._RKIND + cda_p(i,j) = 0._RKIND + ck_p(i,j) = 0._RKIND + cka_p(i,j) = 0._RKIND + q2_p(i,j) = 0._RKIND t2m_p(i,j) = 0._RKIND th2m_p(i,j) = 0._RKIND @@ -214,42 +274,81 @@ subroutine sfclayer_to_MPAS(diag_physics) !================================================================================================== !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + real(kind=RKIND),dimension(:),pointer:: br,cpm,chs,chs2,cqs2,fh,fm,flhc,flqc,gz1oz0,hfx, & + qfx,qgh,qsfc,lh,mol,psim,psih,regime,rmol,ust,ustm, & + wspd,znt,zol + real(kind=RKIND),dimension(:),pointer:: q2,t2m,th2m,u10,v10 !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(diag_physics,'br' , br ) + call mpas_pool_get_array(diag_physics,'cpm' , cpm ) + call mpas_pool_get_array(diag_physics,'chs' , chs ) + call mpas_pool_get_array(diag_physics,'chs2' , chs2 ) + call mpas_pool_get_array(diag_physics,'cqs2' , cqs2 ) + call mpas_pool_get_array(diag_physics,'fh' , fh ) + call mpas_pool_get_array(diag_physics,'fm' , fm ) + call mpas_pool_get_array(diag_physics,'flhc' , flhc ) + call mpas_pool_get_array(diag_physics,'flqc' , flqc ) + call mpas_pool_get_array(diag_physics,'gz1oz0', gz1oz0) + call mpas_pool_get_array(diag_physics,'hfx' , hfx ) + call mpas_pool_get_array(diag_physics,'qfx' , qfx ) + call mpas_pool_get_array(diag_physics,'qgh' , qgh ) + call mpas_pool_get_array(diag_physics,'qsfc' , qsfc ) + call mpas_pool_get_array(diag_physics,'lh' , lh ) + call mpas_pool_get_array(diag_physics,'mol' , mol ) + call mpas_pool_get_array(diag_physics,'psim' , psim ) + call mpas_pool_get_array(diag_physics,'psih' , psih ) + call mpas_pool_get_array(diag_physics,'regime', regime) + call mpas_pool_get_array(diag_physics,'rmol' , rmol ) + call mpas_pool_get_array(diag_physics,'ust' , ust ) + call mpas_pool_get_array(diag_physics,'ustm' , ustm ) + call mpas_pool_get_array(diag_physics,'wspd' , wspd ) + call mpas_pool_get_array(diag_physics,'znt' , znt ) + call mpas_pool_get_array(diag_physics,'zol' , zol ) + + call mpas_pool_get_array(diag_physics,'q2' , q2 ) + call mpas_pool_get_array(diag_physics,'t2m' , t2m ) + call mpas_pool_get_array(diag_physics,'th2m' , th2m ) + call mpas_pool_get_array(diag_physics,'u10' , u10 ) + call mpas_pool_get_array(diag_physics,'v10' , v10 ) + do j = jts,jte do i = its,ite - diag_physics % br % array(i) = br_p(i,j) - diag_physics % cpm % array(i) = cpm_p(i,j) - diag_physics % chs % array(i) = chs_p(i,j) - diag_physics % chs2 % array(i) = chs2_p(i,j) - diag_physics % cqs2 % array(i) = cqs2_p(i,j) - diag_physics % fh % array(i) = fh_p(i,j) - diag_physics % fm % array(i) = fm_p(i,j) - diag_physics % flhc % array(i) = flhc_p(i,j) - diag_physics % flqc % array(i) = flqc_p(i,j) - diag_physics % gz1oz0 % array(i) = gz1oz0_p(i,j) - diag_physics % hfx % array(i) = hfx_p(i,j) - diag_physics % lh % array(i) = lh_p(i,j) - diag_physics % mol % array(i) = mol_p(i,j) - diag_physics % qfx % array(i) = qfx_p(i,j) - diag_physics % qgh % array(i) = qgh_p(i,j) - diag_physics % qsfc % array(i) = qsfc_p(i,j) - diag_physics % psim % array(i) = psim_p(i,j) - diag_physics % psih % array(i) = psih_p(i,j) - diag_physics % regime % array(i) = regime_p(i,j) - diag_physics % rmol % array(i) = rmol_p(i,j) - diag_physics % ust % array(i) = ust_p(i,j) - diag_physics % wspd % array(i) = wspd_p(i,j) - diag_physics % zol % array(i) = zol_p(i,j) - diag_physics % znt % array(i) = znt_p(i,j) + br(i) = br_p(i,j) + cpm(i) = cpm_p(i,j) + chs(i) = chs_p(i,j) + chs2(i) = chs2_p(i,j) + cqs2(i) = cqs2_p(i,j) + fh(i) = fh_p(i,j) + fm(i) = fm_p(i,j) + flhc(i) = flhc_p(i,j) + flqc(i) = flqc_p(i,j) + gz1oz0(i) = gz1oz0_p(i,j) + hfx(i) = hfx_p(i,j) + lh(i) = lh_p(i,j) + mol(i) = mol_p(i,j) + qfx(i) = qfx_p(i,j) + qgh(i) = qgh_p(i,j) + qsfc(i) = qsfc_p(i,j) + psim(i) = psim_p(i,j) + psih(i) = psih_p(i,j) + regime(i) = regime_p(i,j) + rmol(i) = rmol_p(i,j) + ust(i) = ust_p(i,j) + ustm(i) = ustm_p(i,j) + wspd(i) = wspd_p(i,j) + zol(i) = zol_p(i,j) + znt(i) = znt_p(i,j) !diagnostics: - diag_physics % q2 % array(i) = q2_p(i,j) - diag_physics % t2m % array(i) = t2m_p(i,j) - diag_physics % th2m % array(i) = th2m_p(i,j) - diag_physics % u10 % array(i) = u10_p(i,j) - diag_physics % v10 % array(i) = v10_p(i,j) + q2(i) = q2_p(i,j) + t2m(i) = t2m_p(i,j) + th2m(i) = th2m_p(i,j) + u10(i) = u10_p(i,j) + v10(i) = v10_p(i,j) enddo enddo @@ -260,22 +359,22 @@ subroutine init_sfclayer !================================================================================================== !local variables: - logical:: allowed_to_read + logical, parameter:: allowed_to_read = .false. !actually not used in subroutine sfclayinit. !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter sfclayer_initialization:' +! write(0,*) +! write(0,*) '--- enter sfclayer_initialization:' sfclayer_select: select case (trim(sfclayer_scheme)) case("monin_obukhov") - write(0,*) ' enter monin_obukhov initialization:' +! write(0,*) ' enter monin_obukhov initialization:' call sfclayinit(allowed_to_read) - write(0,*) ' end monin_obukhov initialization' +! write(0,*) ' end monin_obukhov initialization' case default end select sfclayer_select - write(0,*) '--- end sfclayer_initialization' +! write(0,*) '--- end sfclayer_initialization' end subroutine init_sfclayer @@ -284,18 +383,21 @@ subroutine driver_sfclayer(mesh,diag_physics,sfc_input) !================================================================================================== !input and inout arguments: -!-------------------------- - type(mesh_type) ,intent(in):: mesh - type(sfc_input_type) ,intent(in):: sfc_input - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + real(kind=RKIND),dimension(:),pointer:: areaCell !local variables: -!---------------- real(kind=RKIND):: dx !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine driver_sfclayer:' +! write(0,*) +! write(0,*) '--- enter subroutine driver_sfclayer:' + + call mpas_pool_get_array(mesh,'areaCell',areaCell) !copy all MPAS arrays to rectanguler grid: call sfclayer_from_MPAS(mesh,diag_physics,sfc_input) @@ -303,11 +405,11 @@ subroutine driver_sfclayer(mesh,diag_physics,sfc_input) sfclayer_select: select case (trim(sfclayer_scheme)) case("monin_obukhov") - dx = sqrt(maxval(mesh % areaCell % array)) + dx = sqrt(maxval(areaCell)) call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & u3d = u_p , v3d = v_p , qv3d = qv_p , & - dz8w = dz_p , cp = cp , g = g , & + dz8w = dz_p , cp = cp , g = gravity , & rovcp = rcp , R = R_d , xlv = xlv , & chs = chs_p , chs2 = chs2_p , cqs2 = cqs2_p , & cpm = cpm_p , znt = znt_p , ust = ust_p , & @@ -340,7 +442,7 @@ subroutine driver_sfclayer(mesh,diag_physics,sfc_input) !copy local arrays to MPAS grid: call sfclayer_to_MPAS(diag_physics) - write(0,*) '--- end subroutine driver_sfclayer' +! write(0,*) '--- end subroutine driver_sfclayer' end subroutine driver_sfclayer diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 4554572e9d..0a8083e38c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -7,18 +7,11 @@ ! !================================================================================================== module mpas_atmphys_init + use mpas_kind_types use mpas_grid_types - use mpas_configure, only: config_do_restart, & - config_lsm_scheme, & - config_microp_scheme, & - config_conv_deep_scheme, & - config_sfclayer_scheme, & - config_radt_lw_scheme, & - config_radt_sw_scheme, & - config_o3climatology use mpas_timekeeping - use mpas_atmphys_driver_convection_deep, only: init_convection_deep + use mpas_atmphys_driver_convection, only: init_convection use mpas_atmphys_driver_lsm,only: init_lsm use mpas_atmphys_driver_microphysics use mpas_atmphys_driver_radiation_lw, only: init_radiation_lw @@ -47,63 +40,172 @@ module mpas_atmphys_init !> add-ons and modifications to sourcecode: !> ---------------------------------------- !> * added structure diag in calls to subroutine init_radiation_lw and init_radiation_sw. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-01. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-01. !> * added call to subroutine init_o3climatology. reads monthly-mean climatological ozone data !> and interpolates ozone data to the MPAS grid. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-03. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-03. !> * added the calculation of the mean distance between cell centers. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-22. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-22. !> * added initialization of variable xicem. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-24. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-24. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * added initialization of the accumulated surface pressure. Added initialization of the +!> tendency and accumulated tendency of the surface pressure. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * renamed config_conv_deep_scheme to config_convection_scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. contains + !================================================================================================== - subroutine physics_init(dminfo,clock,config_do_restart,mesh,diag,state_1,state_2, & - diag_physics,atm_input,sfc_input) + subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_physics, & + atm_input,sfc_input) !================================================================================================== !input arguments: - logical,intent(in):: config_do_restart - type (dm_info), intent(in):: dminfo - type(mesh_type),intent(in):: mesh - type(diag_type),intent(in):: diag + type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs type(MPAS_Clock_type),intent(in):: clock -!inout arguments: - type(state_type),intent(inout):: state_1,state_2 - type(diag_physics_type),intent(inout):: diag_physics - type(atm_input_type),intent(inout):: atm_input - type(sfc_input_type),intent(inout):: sfc_input + integer,intent(in):: time_lev -!local variables: +!inout arguments: + type(mpas_pool_type),intent(inout):: state + type(mpas_pool_type),intent(inout):: diag + type(mpas_pool_type),intent(inout):: tend + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: atm_input + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + logical,pointer:: config_do_restart, & + config_o3climatology + + character(len=StrKIND),pointer:: & + config_lsm_scheme, & + config_microp_scheme, & + config_convection_scheme, & + config_sfclayer_scheme, & + config_radt_lw_scheme, & + config_radt_sw_scheme + + integer,pointer:: nCellsSolve,nLags + integer,dimension(:),pointer :: nEdgesOnCell + integer,dimension(:),pointer :: i_rainc,i_rainnc + integer,dimension(:),pointer :: i_acswdnb,i_acswdnbc,i_acswdnt,i_acswdntc, & + i_acswupb,i_acswupbc,i_acswupt,i_acswuptc, & + i_aclwdnb,i_aclwdnbc,i_aclwdnt,i_aclwdntc, & + i_aclwupb,i_aclwupbc,i_aclwupt,i_aclwuptc + integer,dimension(:,:),pointer:: edgesOnCell + + + real(kind=RKIND),dimension(:),pointer :: dcEdge,dcEdge_m + real(kind=RKIND),dimension(:),pointer :: acswdnb,acswdnbc,acswdnt,acswdntc, & + acswupb,acswupbc,acswupt,acswuptc, & + aclwdnb,aclwdnbc,aclwdnt,aclwdntc, & + aclwupb,aclwupbc,aclwupt,aclwuptc + real(kind=RKIND),dimension(:),pointer :: nsteps_accum,ndays_accum,tday_accum, & + tyear_accum,tyear_mean + real(kind=RKIND),dimension(:),pointer :: sst,sstsk,tmn,xice,xicem + real(kind=RKIND),dimension(:,:),pointer:: tlag + +!local variables and arrays: type(MPAS_Time_Type):: currTime logical:: init_done - integer:: iCell,iLag,ierr,julday - integer:: iEdge,nEdges + integer:: ierr,julday + integer:: iCell,iLag,iEdge,nEdges_m !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine physics_init:' +! write(0,*) +! write(0,*) '--- enter subroutine physics_init:' + + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology ) + call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) + call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) + call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) + call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) + call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nLags' ,nLags ) + + call mpas_pool_get_array(mesh,'nEdgesOnCell',nEdgesOnCell) + call mpas_pool_get_array(mesh,'edgesOnCell' ,edgesOnCell ) + call mpas_pool_get_array(mesh,'dcEdge' ,dcEdge ) + + call mpas_pool_get_array(diag_physics,'dcEdge_m' ,dcEdge_m ) + call mpas_pool_get_array(diag_physics,'i_rainc' ,i_rainc ) + call mpas_pool_get_array(diag_physics,'i_rainnc' ,i_rainnc ) + + call mpas_pool_get_array(diag_physics,'i_acswdnb' ,i_acswdnb ) + call mpas_pool_get_array(diag_physics,'i_acswdnbc' ,i_acswdnbc ) + call mpas_pool_get_array(diag_physics,'i_acswdnt' ,i_acswdnt ) + call mpas_pool_get_array(diag_physics,'i_acswdntc' ,i_acswdntc ) + call mpas_pool_get_array(diag_physics,'i_acswupb' ,i_acswupb ) + call mpas_pool_get_array(diag_physics,'i_acswupbc' ,i_acswupbc ) + call mpas_pool_get_array(diag_physics,'i_acswupt' ,i_acswupt ) + call mpas_pool_get_array(diag_physics,'i_acswuptc' ,i_acswuptc ) + call mpas_pool_get_array(diag_physics,'i_aclwdnb' ,i_aclwdnb ) + call mpas_pool_get_array(diag_physics,'i_aclwdnbc' ,i_aclwdnbc ) + call mpas_pool_get_array(diag_physics,'i_aclwdnt' ,i_aclwdnt ) + call mpas_pool_get_array(diag_physics,'i_aclwdntc' ,i_aclwdntc ) + call mpas_pool_get_array(diag_physics,'i_aclwupb' ,i_aclwupb ) + call mpas_pool_get_array(diag_physics,'i_aclwupbc' ,i_aclwupbc ) + call mpas_pool_get_array(diag_physics,'i_aclwupt' ,i_aclwupt ) + call mpas_pool_get_array(diag_physics,'i_aclwuptc' ,i_aclwuptc ) + + call mpas_pool_get_array(diag_physics,'acswdnb' ,acswdnb ) + call mpas_pool_get_array(diag_physics,'acswdnbc' ,acswdnbc ) + call mpas_pool_get_array(diag_physics,'acswdnt' ,acswdnt ) + call mpas_pool_get_array(diag_physics,'acswdntc' ,acswdntc ) + call mpas_pool_get_array(diag_physics,'acswupb' ,acswupb ) + call mpas_pool_get_array(diag_physics,'acswupbc' ,acswupbc ) + call mpas_pool_get_array(diag_physics,'acswupt' ,acswupt ) + call mpas_pool_get_array(diag_physics,'acswuptc' ,acswuptc ) + call mpas_pool_get_array(diag_physics,'aclwdnb' ,aclwdnb ) + call mpas_pool_get_array(diag_physics,'aclwdnbc' ,aclwdnbc ) + call mpas_pool_get_array(diag_physics,'aclwdnt' ,aclwdnt ) + call mpas_pool_get_array(diag_physics,'aclwdntc' ,aclwdntc ) + call mpas_pool_get_array(diag_physics,'aclwupb' ,aclwupb ) + call mpas_pool_get_array(diag_physics,'aclwupbc' ,aclwupbc ) + call mpas_pool_get_array(diag_physics,'aclwupt' ,aclwupt ) + call mpas_pool_get_array(diag_physics,'aclwuptc' ,aclwuptc ) + + call mpas_pool_get_array(diag_physics,'nsteps_accum',nsteps_accum) + call mpas_pool_get_array(diag_physics,'ndays_accum' ,ndays_accum ) + call mpas_pool_get_array(diag_physics,'tday_accum' ,tday_accum ) + call mpas_pool_get_array(diag_physics,'tyear_accum' ,tyear_accum ) + call mpas_pool_get_array(diag_physics,'tyear_mean' ,tyear_mean ) + call mpas_pool_get_array(diag_physics,'tlag' ,tlag ) + call mpas_pool_get_array(diag_physics,'sstsk' ,sstsk ) + call mpas_pool_get_array(diag_physics,'xicem' ,xicem ) + + call mpas_pool_get_array(sfc_input,'sst' ,sst ) + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'xice',xice) currTime = mpas_get_clock_time(clock,MPAS_NOW,ierr) call mpas_get_time(curr_time=currTime,DoY=julday,ierr=ierr) !calculation of the mean distance between cell centers: if(.not. config_do_restart) then - do iCell = 1, mesh % nCellsSolve - diag_physics % dcEdge_m % array(iCell) = 0._RKIND - nEdges = mesh%nEdgesOnCell%array(iCell) - do iEdge = 1, nEdges - diag_physics%dcEdge_m%array(iCell) = diag_physics%dcEdge_m%array(iCell) & - + mesh%dcEdge%array(mesh%edgesOnCell%array(iEdge,iCell)) + do iCell = 1, nCellsSolve + dcEdge_m(iCell) = 0._RKIND + nEdges_m = nEdgesOnCell(iCell) + do iEdge = 1, nEdges_m + dcEdge_m(iCell) = dcEdge_m(iCell) + dcEdge(edgesOnCell(iEdge,iCell)) enddo - diag_physics % dcEdge_m % array(iCell) = diag_physics % dcEdge_m % array(iCell) & - / nEdges -! write(0,102) iCell,nEdges,(mesh%dcEdge%array(mesh%edgesOnCell%array(iEdge,iCell)), & -! iEdge=1,nEdges),diag_physics%dcEdge_m%array(iCell) + dcEdge_m(iCell) = dcEdge_m(iCell) / nEdges_m +! write(0,102) iCell,nEdges_m,(dcEdge(edgesOnCell(iEdge,iCell)),iEdge=1,nEdges_m),dcEdge_m(iCell) enddo endif 101 format(8i9,10(1x,e15.8)) @@ -117,59 +219,59 @@ subroutine physics_init(dminfo,clock,config_do_restart,mesh,diag,state_1,state_2 !times the accumulated convective (rainc) and grid-scale (rainnc) rain exceed the prescribed !threshold value: if(.not. config_do_restart) then - do iCell = 1, mesh % nCellsSolve - diag_physics % i_rainc % array(iCell) = 0 - diag_physics % i_rainnc % array(iCell) = 0 + do iCell = 1, nCellsSolve + i_rainc(iCell) = 0 + i_rainnc(iCell) = 0 enddo endif !initialization of counters i_acsw* and i_aclw*. i_acsw* and i_aclw* track the number of times !the accumulated long and short-wave radiation fluxes exceed their prescribed theshold values. if(.not. config_do_restart) then - do iCell = 1, mesh % nCellsSolve - diag_physics % i_acswdnb % array(iCell) = 0 - diag_physics % i_acswdnbc % array(iCell) = 0 - diag_physics % i_acswdnt % array(iCell) = 0 - diag_physics % i_acswdntc % array(iCell) = 0 - diag_physics % i_acswupb % array(iCell) = 0 - diag_physics % i_acswupbc % array(iCell) = 0 - diag_physics % i_acswupt % array(iCell) = 0 - diag_physics % i_acswuptc % array(iCell) = 0 - - diag_physics % i_aclwdnb % array(iCell) = 0 - diag_physics % i_aclwdnbc % array(iCell) = 0 - diag_physics % i_aclwdnt % array(iCell) = 0 - diag_physics % i_aclwdntc % array(iCell) = 0 - diag_physics % i_aclwupb % array(iCell) = 0 - diag_physics % i_aclwupbc % array(iCell) = 0 - diag_physics % i_aclwupt % array(iCell) = 0 - diag_physics % i_aclwuptc % array(iCell) = 0 - - diag_physics % acswdnb % array(iCell) = 0._RKIND - diag_physics % acswdnbc % array(iCell) = 0._RKIND - diag_physics % acswdnt % array(iCell) = 0._RKIND - diag_physics % acswdntc % array(iCell) = 0._RKIND - diag_physics % acswupb % array(iCell) = 0._RKIND - diag_physics % acswupbc % array(iCell) = 0._RKIND - diag_physics % acswupt % array(iCell) = 0._RKIND - diag_physics % acswuptc % array(iCell) = 0._RKIND - - diag_physics % aclwdnb % array(iCell) = 0._RKIND - diag_physics % aclwdnbc % array(iCell) = 0._RKIND - diag_physics % aclwdnt % array(iCell) = 0._RKIND - diag_physics % aclwdntc % array(iCell) = 0._RKIND - diag_physics % aclwupb % array(iCell) = 0._RKIND - diag_physics % aclwupbc % array(iCell) = 0._RKIND - diag_physics % aclwupt % array(iCell) = 0._RKIND - diag_physics % aclwuptc % array(iCell) = 0._RKIND + do iCell = 1, nCellsSolve + i_acswdnb(iCell) = 0 + i_acswdnbc(iCell) = 0 + i_acswdnt(iCell) = 0 + i_acswdntc(iCell) = 0 + i_acswupb(iCell) = 0 + i_acswupbc(iCell) = 0 + i_acswupt(iCell) = 0 + i_acswuptc(iCell) = 0 + + i_aclwdnb(iCell) = 0 + i_aclwdnbc(iCell) = 0 + i_aclwdnt(iCell) = 0 + i_aclwdntc(iCell) = 0 + i_aclwupb(iCell) = 0 + i_aclwupbc(iCell) = 0 + i_aclwupt(iCell) = 0 + i_aclwuptc(iCell) = 0 + + acswdnb(iCell) = 0._RKIND + acswdnbc(iCell) = 0._RKIND + acswdnt(iCell) = 0._RKIND + acswdntc(iCell) = 0._RKIND + acswupb(iCell) = 0._RKIND + acswupbc(iCell) = 0._RKIND + acswupt(iCell) = 0._RKIND + acswuptc(iCell) = 0._RKIND + + aclwdnb(iCell) = 0._RKIND + aclwdnbc(iCell) = 0._RKIND + aclwdnt(iCell) = 0._RKIND + aclwdntc(iCell) = 0._RKIND + aclwupb(iCell) = 0._RKIND + aclwupbc(iCell) = 0._RKIND + aclwupt(iCell) = 0._RKIND + aclwuptc(iCell) = 0._RKIND enddo endif !initialization of xicem: if(.not.config_do_restart) then - write(0,*) '--- initialization of xicem:' - do iCell = 1, mesh % nCellsSolve - diag_physics % xicem % array(iCell) = sfc_input % xice % array(iCell) +! write(0,*) '--- initialization of xicem:' + do iCell = 1, nCellsSolve + xicem(iCell) = xice(iCell) enddo endif @@ -177,22 +279,22 @@ subroutine physics_init(dminfo,clock,config_do_restart,mesh,diag,state_1,state_2 !sea-surface temperature is applied. This avoids having the array sstsk equal to !zero over land: if(.not. config_do_restart) then - write(0,*) '--- initialization of sstsk:' - do iCell = 1, mesh % nCellsSolve - diag_physics % sstsk % array(iCell) = sfc_input % sst % array(iCell) +! write(0,*) '--- initialization of sstsk:' + do iCell = 1, nCellsSolve + sstsk(iCell) = sst(iCell) enddo endif !initialization of temperatures needed for updating the deep soil temperature: if(.not. config_do_restart) then - do iCell = 1, mesh % nCellsSolve - diag_physics % nsteps_accum % array(iCell) = 0._RKIND - diag_physics % ndays_accum % array(iCell) = 0._RKIND - diag_physics % tday_accum % array(iCell) = 0._RKIND - diag_physics % tyear_accum % array(iCell) = 0._RKIND - diag_physics % tyear_mean % array(iCell) = sfc_input % tmn % array(iCell) - do iLag = 1, mesh % nLags - diag_physics % tlag % array(iLag,iCell) = sfc_input % tmn % array(iCell) + do iCell = 1, nCellsSolve + nsteps_accum(iCell) = 0._RKIND + ndays_accum(iCell) = 0._RKIND + tday_accum(iCell) = 0._RKIND + tyear_accum(iCell) = 0._RKIND + tyear_mean(iCell) = tmn(iCell) + do iLag = 1, nLags + tlag(iLag,iCell) = tmn(iCell) enddo enddo endif @@ -203,11 +305,11 @@ subroutine physics_init(dminfo,clock,config_do_restart,mesh,diag,state_1,state_2 !initialization of global surface properties. set here for now, but may be moved when time !manager is implemented: - call landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input) + call landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_input) -!initialization of parameterized deep convective processes: - if(config_conv_deep_scheme .ne. 'off') & - call init_convection_deep(config_do_restart,mesh,diag_physics) +!initialization of parameterized convective processes: + if(config_convection_scheme .ne. 'off') & + call init_convection(mesh,configs,diag_physics) !initialization of cloud microphysics processes: if(config_microp_scheme .ne. 'off') call microphysics_init @@ -217,15 +319,15 @@ subroutine physics_init(dminfo,clock,config_do_restart,mesh,diag,state_1,state_2 !initialization of land-surface model: !if(.not. config_do_restart) then -! if(config_lsm_scheme .ne. 'off') call init_lsm(dminfo,mesh,diag_physics,sfc_input) +! if(config_lsm_scheme .ne. 'off') call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) !endif - if(config_lsm_scheme .ne. 'off') call init_lsm(dminfo,mesh,diag_physics,sfc_input) + if(config_lsm_scheme .ne. 'off') call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) !initialization of shortwave radiation processes: init_done = .false. if(config_radt_sw_scheme.ne.'off') then if(trim(config_radt_sw_scheme) .eq. 'cam_sw') then - call init_radiation_sw(dminfo,mesh,atm_input,diag,state_1,state_2) + call init_radiation_sw(dminfo,mesh,atm_input,diag,state,time_lev) init_done = .true. else call init_radiation_sw(dminfo) @@ -238,19 +340,19 @@ subroutine physics_init(dminfo,clock,config_do_restart,mesh,diag,state_1,state_2 if(config_radt_lw_scheme.ne.'off') then if(trim(config_radt_lw_scheme) .eq. 'cam_lw') then if(.not. init_done) then - call init_radiation_lw(dminfo,mesh,atm_input,diag,state_1,state_2) + call init_radiation_lw(dminfo,mesh,atm_input,diag,state,time_lev) else - write(0,*) - write(0,*) '--- camrad lw initialization done above' +! write(0,*) +! write(0,*) '--- camrad lw initialization done above' endif else call init_radiation_lw(dminfo) endif endif - write(0,*) - write(0,*) '--- end subroutine physics_init' - write(0,*) +! write(0,*) +! write(0,*) '--- end subroutine physics_init' +! write(0,*) end subroutine physics_init @@ -260,22 +362,27 @@ subroutine init_dirs_forphys(mesh) !inout arguments: !---------------- - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh -!local variables: - integer:: iCell +!local pointers: + integer,pointer:: nCells real(kind=RKIND),dimension(:),pointer:: latCell,lonCell real(kind=RKIND),dimension(:,:),pointer:: east,north +!local variables: + integer:: iCell + !--------------------------------------------------------------------------------------------- - latCell => mesh % latCell % array - lonCell => mesh % lonCell % array - east => mesh % east % array - north => mesh % north % array + call mpas_pool_get_dimension(mesh,'nCells',nCells) + + call mpas_pool_get_array(mesh,'latCell',latCell) + call mpas_pool_get_array(mesh,'lonCell',lonCell) + call mpas_pool_get_array(mesh,'east' ,east ) + call mpas_pool_get_array(mesh,'north' ,north ) !Compute unit vectors in east and north directions for each cell: - do iCell = 1, mesh % nCells + do iCell = 1, nCells east(1,iCell) = -sin(lonCell(iCell)) east(2,iCell) = cos(lonCell(iCell)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F index 4058f04eca..210e56a21e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F +++ b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F @@ -8,15 +8,10 @@ !================================================================================================== module mpas_atmphys_initialize_real use mpas_kind_types - use mpas_configure, only: config_met_prefix, & - config_frac_seaice, & - config_input_sst, & - config_nsoillevels, & - config_start_time, & - config_sfc_prefix use mpas_dmpar use mpas_grid_types use mpas_init_atm_surface + use mpas_atmphys_date_time use mpas_atmphys_utilities @@ -49,25 +44,33 @@ module mpas_atmphys_initialize_real !> -> removed modifying snoalb (surface albedo over snow) over sea-ice points. !> -> revised subroutine physics_init_sst. !> -> revised subroutine physics_init_seaice. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-02. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-02. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * In subroutine physics_init_seaice, assign the sea-ice land use category as a function of +!> the land use category input file (MODIS OR USGS). +!> Dominikus Heinzeller (IMK) / 2014-07-24. contains !================================================================================================== - subroutine physics_initialize_real(mesh,fg,dminfo) + subroutine physics_initialize_real(mesh, fg, dminfo, dims, configs) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(dm_info),intent(in) :: dminfo + type (mpas_pool_type), intent(in) :: mesh + type (dm_info), intent(in) :: dminfo + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs !inout arguments: - type(fg_type),intent(inout):: fg + type (mpas_pool_type), intent(inout) :: fg !local variables: character(len=StrKIND):: initial_date - integer:: iCell,nCellsSolve + integer:: iCell + integer, pointer :: nCellsSolve integer,dimension(:),pointer:: landmask real(kind=RKIND),dimension(:) ,pointer:: sfc_albbck @@ -79,33 +82,41 @@ subroutine physics_initialize_real(mesh,fg,dminfo) real(kind=RKIND),dimension(:,:),pointer:: greenfrac real(kind=RKIND),dimension(:),pointer:: skintemp,sst + + character (len=StrKIND), pointer :: config_sfc_prefix + character (len=StrKIND), pointer :: config_start_time + logical, pointer :: config_input_sst !temporary: integer:: iSoil,nSoilLevels !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter physics_initialize_real:' - - nCellsSolve = mesh % nCellsSolve - - landmask => mesh % landmask % array - albedo12m => mesh % albedo12m % array - greenfrac => mesh % greenfrac % array - shdmin => mesh % shdmin % array - shdmax => mesh % shdmax % array - - sfc_albbck => fg % sfc_albbck % array - vegfra => fg % vegfra % array - snow => fg % snow % array - snowc => fg % snowc % array - snowh => fg % snowh % array - skintemp => fg % skintemp % array - sst => fg % sst % array - seaice => fg % seaice % array - xice => fg % xice % array - xland => fg % xland % array +! write(0,*) +! write(0,*) '--- enter physics_initialize_real:' + + call mpas_pool_get_config(configs, 'config_sfc_prefix', config_sfc_prefix) + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_input_sst', config_input_sst) + + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'albedo12m', albedo12m) + call mpas_pool_get_array(mesh, 'greenfrac', greenfrac) + call mpas_pool_get_array(mesh, 'shdmin', shdmin) + call mpas_pool_get_array(mesh, 'shdmax', shdmax) + + call mpas_pool_get_array(fg, 'sfc_albbck', sfc_albbck) + call mpas_pool_get_array(fg, 'vegfra', vegfra) + call mpas_pool_get_array(fg, 'snow', snow) + call mpas_pool_get_array(fg, 'snowc', snowc) + call mpas_pool_get_array(fg, 'snowh', snowh) + call mpas_pool_get_array(fg, 'skintemp', skintemp) + call mpas_pool_get_array(fg, 'sst', sst) + call mpas_pool_get_array(fg, 'seaice', seaice) + call mpas_pool_get_array(fg, 'xice', xice) + call mpas_pool_get_array(fg, 'xland', xland) !initialization of xland: do iCell = 1, nCellsSolve @@ -122,8 +133,8 @@ subroutine physics_initialize_real(mesh,fg,dminfo) !in the file defined by config_input_name: if(config_input_sst) then write(0,*) '--- read sea-surface temperature from auxillary file:' - call interp_sfc_to_MPAS(config_start_time(1:13),mesh,fg,dminfo) - call physics_init_sst(mesh,fg) + call interp_sfc_to_MPAS(config_start_time(1:13),mesh,fg,dims,dminfo,config_sfc_prefix) + call physics_init_sst(mesh,fg,dims,configs) endif !initialization of the surface background albedo: interpolation of the monthly values to the @@ -157,52 +168,55 @@ subroutine physics_initialize_real(mesh,fg,dminfo) enddo !initialization of soil layers properties: - call init_soil_layers(mesh,fg,dminfo) + call init_soil_layers(mesh,fg,dminfo,dims,configs) !initialize seaice points: - call physics_init_seaice(mesh,fg) + call physics_init_seaice(mesh,fg,dims,configs) - write(0,*) '--- end physics_initialize_real:' +! write(0,*) '--- end physics_initialize_real:' end subroutine physics_initialize_real !================================================================================================== - subroutine init_soil_layers(mesh,fg,dminfo) + subroutine init_soil_layers(mesh,fg,dminfo,dims,configs) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh type(dm_info),intent(in) :: dminfo + type(mpas_pool_type),intent(in):: dims + type(mpas_pool_type),intent(in):: configs !inout arguments: - type(fg_type),intent(inout):: fg + type(mpas_pool_type),intent(inout):: fg !-------------------------------------------------------------------------------------------------- !adjust the annual mean deep soil temperature: - call adjust_input_soiltemps(mesh,fg) + call adjust_input_soiltemps(mesh,fg,dims) !initialize the depth of the soil layers: - call init_soil_layers_depth(mesh,fg) + call init_soil_layers_depth(mesh,fg,dims,configs) !initialize the temperature, moisture, and liquid water of the individual soil layers: - call init_soil_layers_properties(mesh,fg,dminfo) + call init_soil_layers_properties(mesh,fg,dminfo,dims,configs) end subroutine init_soil_layers !================================================================================================== - subroutine adjust_input_soiltemps(mesh,fg) + subroutine adjust_input_soiltemps(mesh, fg, dims) !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: dims !inout arguments: - type(fg_type),intent(inout):: fg + type (mpas_pool_type), intent(inout) :: fg !local variables: integer:: iCell,ifgSoil - integer:: nCellsSolve,nFGSoilLevels + integer, pointer:: nCellsSolve,nFGSoilLevels integer,dimension(:),pointer:: landmask real(kind=RKIND),dimension(:),pointer :: soilz,ter @@ -211,17 +225,19 @@ subroutine adjust_input_soiltemps(mesh,fg) !-------------------------------------------------------------------------------------------------- - nCellsSolve = mesh % nCellsSolve - nFGSoilLevels = mesh % nFGSoilLevels - landmask => mesh % landmask % array - soiltemp => mesh % soiltemp % array - ter => mesh % ter % array + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(dims, 'nFGSoilLevels', nFGSoilLevels) + + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'soiltemp', soiltemp) + call mpas_pool_get_array(mesh, 'ter', ter) + + call mpas_pool_get_array(fg, 'skintemp', skintemp) + call mpas_pool_get_array(fg, 'tmn', tmn) + call mpas_pool_get_array(fg, 'st_fg', st_fg) + call mpas_pool_get_array(fg, 'soilz', soilz) - skintemp => fg % skintemp % array - tmn => fg % tmn % array - st_fg => fg % st_fg % array - soilz => fg % soilz % array do iCell = 1, nCellsSolve if(landmask(iCell) .eq. 1) then @@ -233,7 +249,7 @@ subroutine adjust_input_soiltemps(mesh,fg) !adjust the soil layer temperatures: do ifgSoil = 1, nFGSoilLevels st_fg(ifgSoil,iCell) = st_fg(ifgSoil,iCell) - 0.0065_RKIND * (ter(iCell)-soilz(iCell)) - enddo + end do elseif(landmask(iCell) .eq. 0) then @@ -245,55 +261,66 @@ subroutine adjust_input_soiltemps(mesh,fg) end subroutine adjust_input_soiltemps !================================================================================================== - subroutine init_soil_layers_depth(mesh,fg) + subroutine init_soil_layers_depth(mesh, fg, dims, configs) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs !inout arguments: - type(fg_type),intent(inout):: fg + type (mpas_pool_type), intent(inout) :: fg -!local variables: - integer:: iCell,iSoil - integer:: nCellsSolve,nSoilLevels,nFGSoilLevels +!local variables and arrays: + integer :: iCell,iSoil + integer, pointer :: nCellsSolve,nSoilLevels,nFGSoilLevels + integer, pointer :: config_nsoillevels + + real(kind=RKIND),dimension(:,:),pointer:: dzs_fg,zs_fg + real(kind=RKIND),dimension(:,:),pointer:: dzs,zs !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine init_soil_layers_depth:' +! write(0,*) +! write(0,*) '--- enter subroutine init_soil_layers_depth:' - nCellsSolve = mesh % nCellsSolve - nSoilLevels = mesh % nSoilLevels - nFGSoilLevels = mesh % nFGSoilLevels + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(dims, 'nSoilLevels', nSoilLevels) + call mpas_pool_get_dimension(dims, 'nFGSoilLevels', nFGSoilLevels) + + call mpas_pool_get_array(fg, 'zs_fg', zs_fg) + call mpas_pool_get_array(fg, 'dzs_fg', dzs_fg) + call mpas_pool_get_array(fg, 'zs', zs) + call mpas_pool_get_array(fg, 'dzs', dzs) + + call mpas_pool_get_config(configs, 'config_nsoillevels', config_nsoillevels) if(config_nsoillevels .ne. 4) & call physics_error_fatal('NOAH lsm uses 4 soil layers. Correct config_nsoillevels.') do iCell = 1, nCellsSolve - iSoil = 1 - fg % zs_fg % array(iSoil,iCell) = 0.5_RKIND * fg % dzs_fg % array(iSoil,iCell) + zs_fg(iSoil,iCell) = 0.5_RKIND * dzs_fg(iSoil,iCell) do iSoil = 2, nFGSoilLevels - fg % zs_fg % array(iSoil,iCell) = fg % zs_fg % array(iSoil-1,iCell) & - + 0.5_RKIND * fg % dzs_fg % array(iSoil-1,iCell) & - + 0.5_RKIND * fg % dzs_fg % array(iSoil,iCell) + zs_fg(iSoil,iCell) = zs_fg(iSoil-1,iCell) & + + 0.5_RKIND * dzs_fg(iSoil-1,iCell) & + + 0.5_RKIND * dzs_fg(iSoil,iCell) enddo - enddo do iCell = 1, nCellsSolve - fg % dzs % array(1,iCell) = 0.10_RKIND - fg % dzs % array(2,iCell) = 0.30_RKIND - fg % dzs % array(3,iCell) = 0.60_RKIND - fg % dzs % array(4,iCell) = 1.00_RKIND + dzs(1,iCell) = 0.10_RKIND + dzs(2,iCell) = 0.30_RKIND + dzs(3,iCell) = 0.60_RKIND + dzs(4,iCell) = 1.00_RKIND iSoil = 1 - fg % zs % array(iSoil,iCell) = 0.5_RKIND * fg % dzs % array(iSoil,iCell) + zs(iSoil,iCell) = 0.5_RKIND * dzs(iSoil,iCell) do iSoil = 2, nSoilLevels - fg % zs % array(iSoil,iCell) = fg % zs % array(iSoil-1,iCell) & - + 0.5_RKIND * fg % dzs % array(iSoil-1,iCell) & - + 0.5_RKIND * fg % dzs % array(iSoil,iCell) + zs(iSoil,iCell) = zs(iSoil-1,iCell) & + + 0.5_RKIND * dzs(iSoil-1,iCell) & + + 0.5_RKIND * dzs(iSoil,iCell) enddo enddo @@ -301,19 +328,21 @@ subroutine init_soil_layers_depth(mesh,fg) end subroutine init_soil_layers_depth !================================================================================================== - subroutine init_soil_layers_properties(mesh,fg,dminfo) + subroutine init_soil_layers_properties(mesh, fg, dminfo, dims, configs) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(dm_info),intent(in) :: dminfo + type (mpas_pool_type), intent(in) :: mesh + type (dm_info), intent(in) :: dminfo + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs !inout arguments: - type(fg_type),intent(inout):: fg + type (mpas_pool_type), intent(inout) :: fg !local variables: integer:: iCell,ifgSoil,iSoil - integer:: nCellsSolve,nFGSoilLevels,nSoilLevels + integer, pointer:: nCellsSolve,nFGSoilLevels,nSoilLevels integer:: num_sm,num_st integer,dimension(:),pointer:: landmask @@ -323,31 +352,35 @@ subroutine init_soil_layers_properties(mesh,fg,dminfo) real(kind=RKIND),dimension(:,:),pointer:: dzs,zs,tslb,smois,sh2o,smcrel real(kind=RKIND),dimension(:,:),pointer:: sm_fg,st_fg,zs_fg + integer, pointer :: config_nsoillevels + !-------------------------------------------------------------------------------------------------- !write(0,*) - write(0,*) '--- enter subroutine init_soil_layers_properties:' +! write(0,*) '--- enter subroutine init_soil_layers_properties:' + + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(dims, 'nSoilLevels', nSoilLevels) + call mpas_pool_get_dimension(dims, 'nFGSoilLevels', nFGSoilLevels) + + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(fg, 'zs_fg', zs_fg) + call mpas_pool_get_array(fg, 'st_fg', st_fg) + call mpas_pool_get_array(fg, 'sm_fg', sm_fg) + call mpas_pool_get_array(fg, 'zs', zs) + call mpas_pool_get_array(fg, 'dzs', dzs) + call mpas_pool_get_array(fg, 'sh2o', sh2o) + call mpas_pool_get_array(fg, 'smcrel', smcrel) + call mpas_pool_get_array(fg, 'smois', smois) + call mpas_pool_get_array(fg, 'tslb', tslb) + call mpas_pool_get_array(fg, 'skintemp', skintemp) + call mpas_pool_get_array(fg, 'tmn', tmn) + + call mpas_pool_get_config(configs, 'config_nsoillevels', config_nsoillevels) - nCellsSolve = mesh % nCellsSolve - nSoilLevels = mesh % nSoilLevels - nFGSoilLevels = mesh % nFGSoilLevels write(0,*) 'nSoilLevels =',nSoilLevels write(0,*) 'nFGSoilLevels =',nFGSoilLevels - landmask => mesh % landmask % array - - zs_fg => fg % zs_fg % array - st_fg => fg % st_fg % array - sm_fg => fg % sm_fg % array - - zs => fg % zs % array - dzs => fg % dzs % array - sh2o => fg % sh2o % array - smcrel => fg % smcrel % array - smois => fg % smois % array - tslb => fg % tslb % array - skintemp => fg % skintemp % array - tmn => fg % tmn % array !check that interpolation of the meteorological data to the MPAS grid did not create negative !values for the first-guess soil temperatures and soil moistures. @@ -473,42 +506,42 @@ subroutine init_soil_layers_properties(mesh,fg,dminfo) end subroutine init_soil_layers_properties !================================================================================================== - subroutine physics_init_sst(mesh,input) + subroutine physics_init_sst(mesh, input, dims, configs) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - -#if !defined(mpas) -!inout arguments: this subroutine is called from the MPAS initialization side. - type(fg_type),intent(inout):: input -#else -!inout arguments: this subroutine is called from the MPAS model side. - type(sfc_input_type),intent(inout):: input -#endif + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(inout) :: input + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs !local variables: character(len=StrKIND):: mess - integer:: iCell,nCellsSolve + integer, pointer:: nCellsSolve + integer:: iCell integer:: num_seaice_changes integer,dimension(:),pointer:: landmask real(kind=RKIND):: xice_threshold real(kind=RKIND),dimension(:),pointer :: seaice,sst,tsk,xice + logical, pointer :: config_frac_seaice + !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine physics_init_sst:' +! write(0,*) +! write(0,*) '--- enter subroutine physics_init_sst:' + + call mpas_pool_get_config(configs, 'config_frac_seaice', config_frac_seaice) -!initialization: - nCellsSolve = mesh % nCellsSolve + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(input, 'sst', sst) + call mpas_pool_get_array(input, 'seaice', seaice) + call mpas_pool_get_array(input, 'skintemp', tsk) + call mpas_pool_get_array(input, 'xice', xice) - landmask => mesh % landmask % array - sst => input % sst % array - seaice => input % seaice % array - tsk => input % skintemp % array - xice => input % xice % array if(.not. config_frac_seaice) then xice_threshold = 0.5_RKIND @@ -538,28 +571,26 @@ subroutine physics_init_sst(mesh,input) num_seaice_changes call physics_message(mess) - write(0,*) '--- end subroutine physics_init_sst:' +! write(0,*) '--- end subroutine physics_init_sst:' end subroutine physics_init_sst !================================================================================================== - subroutine physics_init_seaice(mesh,input) + subroutine physics_init_seaice(mesh, input, dims, configs) !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs -#if !defined(mpas) -!inout arguments: this subroutine is called from the MPAS initialization side. - type(fg_type),intent(inout):: input -#else !inout arguments: this subroutine is called from the MPAS model side. - type(sfc_input_type),intent(inout):: input -#endif + type (mpas_pool_type), intent(inout) :: input !local variables: character(len=StrKIND):: mess - integer:: iCell,iSoil,nCellsSolve,nSoilLevels + integer, pointer:: nCellsSolve,nSoilLevels + integer:: iCell,iSoil integer:: num_seaice_changes integer,dimension(:),pointer:: landmask,isltyp,ivgtyp @@ -570,6 +601,10 @@ subroutine physics_init_seaice(mesh,input) real(kind=RKIND),dimension(:),pointer :: skintemp,tmn,xland real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o,smcrel + logical, pointer :: config_frac_seaice + character(len=StrKIND),pointer:: config_landuse_data + integer:: isice_lu + !note that this threshold is also defined in module_physics_vars.F.It is defined here to avoid !adding "use module_physics_vars" since this subroutine is only used for the initialization of !a "real" forecast with $CORE = init_nhyd_atmos. @@ -577,28 +612,44 @@ subroutine physics_init_seaice(mesh,input) real(kind=RKIND),parameter:: total_depth = 3. ! 3-meter soil depth. !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter physics_init_seaice:' - - nCellsSolve = mesh % nCellsSolve - nSoilLevels = mesh % nSoilLevels - - landmask => mesh % landmask % array - isltyp => mesh % soilcat_top % array - ivgtyp => mesh % lu_index % array - - seaice => input % seaice % array - xice => input % xice % array - vegfra => input % vegfra % array - - skintemp => input % skintemp % array - tmn => input % tmn % array - xland => input % xland % array - - tslb => input % tslb % array - smois => input % smois % array - sh2o => input % sh2o % array - smcrel => input % smcrel % array +! write(0,*) +! write(0,*) '--- enter physics_init_seaice:' + + call mpas_pool_get_config(configs, 'config_frac_seaice', config_frac_seaice) + call mpas_pool_get_config(configs, 'config_landuse_data', config_landuse_data) + + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(dims, 'nSoilLevels', nSoilLevels) + + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'lu_index', ivgtyp) + call mpas_pool_get_array(mesh, 'soilcat_top', isltyp) + + call mpas_pool_get_array(input, 'seaice', seaice) + call mpas_pool_get_array(input, 'xice', xice) + call mpas_pool_get_array(input, 'vegfra', vegfra) + + call mpas_pool_get_array(input, 'skintemp', skintemp) + call mpas_pool_get_array(input, 'tmn', tmn) + call mpas_pool_get_array(input, 'xland', xland) + + call mpas_pool_get_array(input, 'tslb', tslb) + call mpas_pool_get_array(input, 'smois', smois) + call mpas_pool_get_array(input, 'sh2o', sh2o) + call mpas_pool_get_array(input, 'smcrel', smcrel) + +!define the land use category for sea-ice as a function of the land use category input file: + sfc_input_select1: select case(trim(config_landuse_data)) + case('OLD') + isice_lu = 11 + case('USGS') + isice_lu = 24 + case('MODIFIED_IGBP_MODIS_NOAH') + isice_lu = 15 + case default + CALL physics_error_fatal ('Invalid Land Use Dataset '//trim(config_landuse_data)) + end select sfc_input_select1 + write(0,*) '--- isice_lu = ',isice_lu !assign the threshold value for xice as a function of config_frac_seaice: if(.not. config_frac_seaice) then @@ -626,7 +677,7 @@ subroutine physics_init_seaice(mesh,input) num_seaice_changes = num_seaice_changes + 1 !... sea-ice points are converted to land points: if(landmask(iCell) .eq. 0) tmn(iCell) = 271.4_RKIND - ivgtyp(iCell) = 24 ! (isice = 24) + ivgtyp(iCell) = isice_lu isltyp(iCell) = 16 vegfra(iCell) = 0._RKIND xland(iCell) = 1._RKIND @@ -663,7 +714,7 @@ subroutine physics_init_seaice(mesh,input) enddo 101 format(i9,5(1x,e15.8)) - write(0,*) '--- end physics_init_seaice:' +! write(0,*) '--- end physics_init_seaice:' end subroutine physics_init_seaice diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface_nhyd.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F similarity index 54% rename from src/core_atmosphere/physics/mpas_atmphys_interface_nhyd.F rename to src/core_atmosphere/physics/mpas_atmphys_interface.F index 7a0c07d2c3..641fe1dc6e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface_nhyd.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -6,8 +6,8 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! !================================================================================================== - module mpas_atmphys_interface_nhyd - use mpas_configure + module mpas_atmphys_interface + use mpas_kind_types use mpas_grid_types use mpas_atmphys_constants @@ -23,7 +23,6 @@ module mpas_atmphys_interface_nhyd integer:: i,j,k - !>\brief interface for conversion between variables used in the MPAS dynamical core and variables !> needed in the physics parameterizations. !>\author Laura D. Fowler (send comments to laura@ucar.edu). @@ -38,10 +37,39 @@ module mpas_atmphys_interface_nhyd !> MPAS_to_physics : conversion of input "MPAS" variables to "physics" variables. !> microphysics_from_MPAS : initialize local arrays needed in cloud microphysics schemes. !> microphysics_to_MPAS : copy local arrays needed in cloud microphysics schemesto MPAS arrays. +!> +!> add-ons and modifications to sourcecode: +!> ---------------------------------------- +!> * In subroutine MPAS_to_physics, moved the calculation of the local arrays qv_p,qc_p, and +!> qr_p above the calculation of th_p so that we do not need to use the pointer qv. +!> * In subroutine microphysics_from_MPAS, moved the calculation of the local arrays qv_p,qc_p, +!> and qr_p above the calculation of th_p so that we do not need to use the pointer qv. +!> * In subroutine microphysics_to_MPAS, since microphysics schemes update the temperature and +!> water vapor mixing ratio, we first update the total pressure and exner functions. Then, we +!> update the modified potential temperature and calculate the diabatic tendency due to cloud +!> microphysics processes. +!> Laura D. Fowler (laura@ucar.edu) / 2013-11-07. +!> * Replaced the variable g (that originally pointed to gravity) with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * Modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * Added calculation of the surface pressure tendency. Moved the calculation of znu_p below +!> the calculation of the surface pressure to avoid dividing by zero if the surface pressure +!> is not output in the init file. +!> Laura D. Fowler (birch.mmm.ucar.ecu) / 2014-06-23. +!> * Renamed module mpas_atmphys_interface_nhyd to mpas_atmphys_interface. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-19. +!> * In subroutine microphysics_to_MPAS, reverted the calculation of cloud microphysics tendency +!> rt_diabatic_tend, and update of the state variables to git hash identifier 7a66f273e182f4. +!> This change reflects the fact that we want to compute rt_diabatic_tend at constant volume. +!> Laura D. Fowler (laura@ucar.edu) / 2014-1-015. contains + !================================================================================================== subroutine allocate_forall_physics !================================================================================================== @@ -134,96 +162,98 @@ subroutine deallocate_forall_physics end subroutine deallocate_forall_physics !================================================================================================== - subroutine MPAS_to_physics(mesh,state,diag,diag_physics) + subroutine MPAS_to_physics(mesh,state,time_lev,diag,diag_physics) !================================================================================================== !input variables: - type(mesh_type) ,intent(in):: mesh - type(state_type),intent(in):: state - type(diag_type) ,intent(in):: diag + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + + integer,intent(in):: time_lev !inout variables: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg + real(kind=RKIND),dimension(:),pointer :: latCell,lonCell + real(kind=RKIND),dimension(:),pointer :: fzm,fzp,rdzw + real(kind=RKIND),dimension(:),pointer :: surface_pressure,plrad + real(kind=RKIND),dimension(:,:),pointer :: zgrid + real(kind=RKIND),dimension(:,:),pointer :: zz,exner,pressure_b,rtheta_p,rtheta_b + real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p,u,v,w + real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg + real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: integer:: i,k,j - real(kind=RKIND):: z0,z1,z2,w1,w2 - - real(kind=RKIND),dimension(:),pointer:: latCell,lonCell - real(kind=RKIND),dimension(:),pointer :: fzm,fzp,rdzw - real(kind=RKIND),dimension(:),pointer :: sfc_pressure - real(kind=RKIND),dimension(:,:),pointer:: zgrid - real(kind=RKIND),dimension(:,:),pointer:: zz,exner,pressure_b,rtheta_p,rtheta_b - real(kind=RKIND),dimension(:,:),pointer:: rho_zz,theta_m,qv,pressure_p,u,v,w - real(kind=RKIND),dimension(:,:),pointer:: qvs,rh + real(kind=RKIND):: z0,z1,z2,w1,w2 real(kind=RKIND):: rho_a,rho1,rho2,tem1,tem2 !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine MPAS_to_phys:' - write(0,*) 'ims=',ims,' ime=',ime - write(0,*) 'jms=',jms,' jme=',jme - write(0,*) 'kms=',kms,' kme=',kme - write(0,*) - write(0,*) 'its=',its,' ite=',ite - write(0,*) 'jts=',jts,' jte=',jte - write(0,*) 'kts=',kts,' kte=',kte +! write(0,*) +! write(0,*) '--- enter subroutine MPAS_to_phys:' +! write(0,*) 'ims=',ims,' ime=',ime +! write(0,*) 'jms=',jms,' jme=',jme +! write(0,*) 'kms=',kms,' kme=',kme +! write(0,*) +! write(0,*) 'its=',its,' ite=',ite +! write(0,*) 'jts=',jts,' jte=',jte +! write(0,*) 'kts=',kts,' kte=',kte !initialization: - latCell => mesh % latCell % array - lonCell => mesh % lonCell % array - - fzm => mesh % fzm % array - fzp => mesh % fzp % array - rdzw => mesh % rdzw % array - zgrid => mesh % zgrid % array - zz => mesh % zz % array - sfc_pressure => diag % surface_pressure % array - exner => diag % exner % array - pressure_b => diag % pressure_base % array - pressure_p => diag % pressure_p % array - rtheta_p => diag % rtheta_p % array - rtheta_b => diag % rtheta_base % array - - rho_zz => state % rho_zz % array - theta_m => state % theta_m % array - qv => state % scalars % array(state%index_qv,:,:) - - w => state % w % array - u => diag % uReconstructZonal % array - v => diag % uReconstructMeridional % array - -!calculation of the surface pressure using hydrostatic assumption down to the surface:: - do i = its,ite - tem1 = zgrid(2,i)-zgrid(1,i) - tem2 = zgrid(3,i)-zgrid(2,i) - rho1 = rho_zz(1,i) * zz(1,i) * (1. + qv(1,i)) - rho2 = rho_zz(2,i) * zz(2,i) * (1. + qv(2,i)) - sfc_pressure(i) = 0.5*g*(zgrid(2,i)-zgrid(1,i)) & - * (rho1 + 0.5*(rho2-rho1)*tem1/(tem1+tem2)) - sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i) - enddo - -!arrays located at theta points: -!do j = jts, jte -!do i = its, ite -! psfc_p(i,j) = diag % surface_pressure % array(i) -!enddo -!enddo + call mpas_pool_get_array(mesh,'latCell',latCell) + call mpas_pool_get_array(mesh,'lonCell',lonCell) + call mpas_pool_get_array(mesh,'fzm' ,fzm ) + call mpas_pool_get_array(mesh,'fzp' ,fzp ) + call mpas_pool_get_array(mesh,'rdzw' ,rdzw ) + call mpas_pool_get_array(mesh,'zgrid' ,zgrid ) + call mpas_pool_get_array(mesh,'zz' ,zz ) + + call mpas_pool_get_array(diag,'surface_pressure' ,surface_pressure) + call mpas_pool_get_array(diag,'exner' ,exner ) + call mpas_pool_get_array(diag,'pressure_base' ,pressure_b ) + call mpas_pool_get_array(diag,'pressure_p' ,pressure_p ) + call mpas_pool_get_array(diag,'rtheta_base' ,rtheta_b ) + call mpas_pool_get_array(diag,'rtheta_p' ,rtheta_p ) + call mpas_pool_get_array(diag,'uReconstructZonal' ,u ) + call mpas_pool_get_array(diag,'uReconstructMeridional',v ) + + call mpas_pool_get_array(state,'rho_zz' ,rho_zz ,time_lev) + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + call mpas_pool_get_array(state,'w' ,w ,time_lev) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_dimension(state,'index_qc',index_qc) + call mpas_pool_get_dimension(state,'index_qr',index_qr) + call mpas_pool_get_dimension(state,'index_qi',index_qi) + call mpas_pool_get_dimension(state,'index_qs',index_qs) + call mpas_pool_get_dimension(state,'index_qg',index_qg) + + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + qv => scalars(index_qv,:,:) + qc => scalars(index_qc,:,:) + qr => scalars(index_qr,:,:) + qi => scalars(index_qi,:,:) + qs => scalars(index_qs,:,:) + qg => scalars(index_qg,:,:) + + call mpas_pool_get_array(diag_physics,'plrad',plrad) do j = jts, jte do k = kts, kte do i = its, ite - !moist arrays: - qv_p(i,k,j) = max(0.,state % scalars % array(state%index_qv,k,i)) - qc_p(i,k,j) = max(0.,state % scalars % array(state%index_qc,k,i)) - qr_p(i,k,j) = max(0.,state % scalars % array(state%index_qr,k,i)) - qi_p(i,k,j) = max(0.,state % scalars % array(state%index_qi,k,i)) - qs_p(i,k,j) = max(0.,state % scalars % array(state%index_qs,k,i)) - qg_p(i,k,j) = max(0.,state % scalars % array(state%index_qg,k,i)) + !water vapor and moist arrays: + qv_p(i,k,j) = max(0.,qv(k,i)) + qc_p(i,k,j) = max(0.,qc(k,i)) + qr_p(i,k,j) = max(0.,qr(k,i)) + qi_p(i,k,j) = max(0.,qi(k,i)) + qs_p(i,k,j) = max(0.,qs(k,i)) + qg_p(i,k,j) = max(0.,qg(k,i)) !arrays located at theta points: u_p(i,k,j) = u(k,i) @@ -231,13 +261,12 @@ subroutine MPAS_to_physics(mesh,state,diag,diag_physics) zz_p(i,k,j) = zz(k,i) rho_p(i,k,j) = zz(k,i) * rho_zz(k,i) - rho_p(i,k,j) = rho_p(i,k,j)*(1.+qv_p(i,k,j)) - th_p(i,k,j) = theta_m(k,i) / (1. + R_v/R_d * qv(k,i)) - t_p(i,k,j) = theta_m(k,i) * exner(k,i) / (1. + R_v/R_d * qv(k,i)) + rho_p(i,k,j) = rho_p(i,k,j)*(1._RKIND + qv_p(i,k,j)) + th_p(i,k,j) = theta_m(k,i) / (1._RKIND + R_v/R_d * qv_p(i,k,j)) + t_p(i,k,j) = th_p(i,k,j)*exner(k,i) pi_p(i,k,j) = exner(k,i) pres_p(i,k,j) = pressure_p(k,i) + pressure_b(k,i) - znu_p(i,k,j) = pres_p(i,k,j) / sfc_pressure(i) zmid_p(i,k,j) = 0.5*(zgrid(k+1,i)+zgrid(k,i)) dz_p(i,k,j) = zgrid(k+1,i)-zgrid(k,i) @@ -246,6 +275,25 @@ subroutine MPAS_to_physics(mesh,state,diag,diag_physics) enddo enddo +!calculation of the surface pressure using hydrostatic assumption down to the surface:: + do j = jts,jte + do i = its,ite + tem1 = zgrid(2,i)-zgrid(1,i) + tem2 = zgrid(3,i)-zgrid(2,i) + rho1 = rho_zz(1,i) * zz(1,i) * (1. + qv_p(i,1,j)) + rho2 = rho_zz(2,i) * zz(2,i) * (1. + qv_p(i,2,j)) + surface_pressure(i) = 0.5*gravity*(zgrid(2,i)-zgrid(1,i)) & + * (rho1 + 0.5*(rho2-rho1)*tem1/(tem1+tem2)) + surface_pressure(i) = surface_pressure(i) + pressure_p(1,i) + pressure_b(1,i) + enddo + + do k = kts,kte + do i = its,ite + znu_p(i,k,j) = pres_p(i,k,j) / surface_pressure(i) + enddo + enddo + enddo + !arrays located at w points: do j = jts, jte do k = kts,kte+1 @@ -270,7 +318,7 @@ subroutine MPAS_to_physics(mesh,state,diag,diag_physics) write(0,201) j,i,k,dz_p(i,k,j),pressure_b(k,i),pressure_p(k,i),pres_p(i,k,j), & rho_p(i,k,j),th_p(i,k,j),t_p(i,k,j),qv_p(i,k,j) enddo -! stop +! call mpas_dmpar_global_abort('ERROR: pressure increasing with height') endif enddo enddo @@ -330,8 +378,8 @@ subroutine MPAS_to_physics(mesh,state,diag,diag_physics) pres2_hydd_p(i,k,j) = pres2_p(i,k,j) do k = kte,1,-1 rho_a = rho_p(i,k,j) / (1.+qv_p(i,k,j)) - pres2_hyd_p(i,k,j) = pres2_hyd_p(i,k+1,j) + g*rho_p(i,k,j)*dz_p(i,k,j) - pres2_hydd_p(i,k,j) = pres2_hydd_p(i,k+1,j) + g*rho_a*dz_p(i,k,j) + pres2_hyd_p(i,k,j) = pres2_hyd_p(i,k+1,j) + gravity*rho_p(i,k,j)*dz_p(i,k,j) + pres2_hydd_p(i,k,j) = pres2_hydd_p(i,k+1,j) + gravity*rho_a*dz_p(i,k,j) enddo !pressure at theta-points: do k = kte,1,-1 @@ -351,7 +399,7 @@ subroutine MPAS_to_physics(mesh,state,diag,diag_physics) !save the model-top pressure: do j = jts,jte do i = its,ite - diag_physics % plrad % array(i) = pres2_p(i,kte+1,j) + plrad(i) = pres2_p(i,kte+1,j) enddo enddo @@ -363,77 +411,76 @@ subroutine MPAS_to_physics(mesh,state,diag,diag_physics) end subroutine MPAS_to_physics !================================================================================================== - subroutine microphysics_from_MPAS(mesh,state,tend,diag) + subroutine microphysics_from_MPAS(mesh,state,time_lev,diag) !================================================================================================== !input variables: - type(state_type),intent(in):: state - type(diag_type) ,intent(in):: diag - type(mesh_type) ,intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: mesh - type(tend_type),intent(inout):: tend + integer:: time_lev + +!local pointers: + integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg + real(kind=RKIND),dimension(:,:),pointer :: zgrid + real(kind=RKIND),dimension(:,:),pointer :: zz,exner,pressure_b,rtheta_p,rtheta_b + real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p + real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg + real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: integer:: i,k,j - real(kind=RKIND):: min_theta,min_thp,min_tp - real(kind=RKIND):: max_theta,max_thp,max_tp - real(kind=RKIND):: min_qv,min_qc,min_qr,min_qi,min_qs,min_qg - real(kind=RKIND):: max_qv,max_qc,max_qr,max_qi,max_qs,max_qg - - real(kind=RKIND),dimension(:,:),pointer:: zgrid - real(kind=RKIND),dimension(:,:),pointer:: zz,exner,pressure_b,rtheta_p,rtheta_b - real(kind=RKIND),dimension(:,:),pointer:: rho_zz,theta_m,qv,rh,pressure_p - real(kind=RKIND),dimension(:,:),pointer:: rt_diabatic_tend - !-------------------------------------------------------------------------------------------------- !initialization: - write(0,*) - write(0,*) '--- enter subroutine microphysics_from_MPAS:' - - zgrid => mesh % zgrid % array - zz => mesh % zz % array - - exner => diag % exner % array - pressure_b => diag % pressure_base % array - pressure_p => diag % pressure_p % array - rtheta_p => diag % rtheta_p % array - rtheta_b => diag % rtheta_base % array - - rho_zz => state % rho_zz % array - theta_m => state % theta_m % array - rh => diag % rh % array - - rt_diabatic_tend => tend % rt_diabatic_tend % array - - qv => state % scalars % array(state%index_qv,:,:) - - do k = kts,kte - do i = its,ite - rt_diabatic_tend(k,i) = 0. - enddo - enddo - -!copy sounding variables from the geodesic grid to the wrf-physics grid: +! write(0,*) +! write(0,*) '--- enter subroutine microphysics_from_MPAS:' + + call mpas_pool_get_array(mesh,'zgrid',zgrid) + call mpas_pool_get_array(mesh,'zz' ,zz ) + + call mpas_pool_get_array(diag,'exner' ,exner ) + call mpas_pool_get_array(diag,'pressure_base',pressure_b) + call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) + call mpas_pool_get_array(diag,'rtheta_base' ,rtheta_b ) + call mpas_pool_get_array(diag,'rtheta_p' ,rtheta_p ) + + call mpas_pool_get_array(state,'rho_zz' ,rho_zz ,time_lev) + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_dimension(state,'index_qc',index_qc) + call mpas_pool_get_dimension(state,'index_qr',index_qr) + call mpas_pool_get_dimension(state,'index_qi',index_qi) + call mpas_pool_get_dimension(state,'index_qs',index_qs) + call mpas_pool_get_dimension(state,'index_qg',index_qg) + + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + qv => scalars(index_qv,:,:) + qc => scalars(index_qc,:,:) + qr => scalars(index_qr,:,:) + qi => scalars(index_qi,:,:) + qs => scalars(index_qs,:,:) + qg => scalars(index_qg,:,:) + +!initialize variables needed in the cloud microphysics schemes: do j = jts, jte do k = kts, kte do i = its, ite + qv_p(i,k,j) = qv(k,i) + qc_p(i,k,j) = qc(k,i) + qr_p(i,k,j) = qr(k,i) + rho_p(i,k,j) = zz(k,i) * rho_zz(k,i) - th_p(i,k,j) = theta_m(k,i) / (1. + R_v/R_d * max(0.,qv(k,i))) + th_p(i,k,j) = theta_m(k,i) / (1._RKIND + R_v/R_d * max(0._RKIND,qv_p(i,k,j))) pi_p(i,k,j) = exner(k,i) pres_p(i,k,j) = pressure_b(k,i) + pressure_p(k,i) z_p(i,k,j) = zgrid(k,i) dz_p(i,k,j) = zgrid(k+1,i) - zgrid(k,i) - -! qv_p(i,k,j) = max(0.,state % scalars % array(state%index_qv,k,i)) -! qc_p(i,k,j) = max(0.,state % scalars % array(state%index_qc,k,i)) -! qr_p(i,k,j) = max(0.,state % scalars % array(state%index_qr,k,i)) - qv_p(i,k,j) = state % scalars % array(state%index_qv,k,i) - qc_p(i,k,j) = state % scalars % array(state%index_qc,k,i) - qr_p(i,k,j) = state % scalars % array(state%index_qr,k,i) enddo enddo enddo @@ -445,12 +492,9 @@ subroutine microphysics_from_MPAS(mesh,state,tend,diag) do j = jts, jte do k = kts, kte do i = its, ite -! qi_p(i,k,j) = max(0.,vars % scalars % array(vars%index_qi,k,i)) -! qs_p(i,k,j) = max(0.,vars % scalars % array(vars%index_qs,k,i)) -! qg_p(i,k,j) = max(0.,vars % scalars % array(vars%index_qg,k,i)) - qi_p(i,k,j) = state % scalars % array(state%index_qi,k,i) - qs_p(i,k,j) = state % scalars % array(state%index_qs,k,i) - qg_p(i,k,j) = state % scalars % array(state%index_qg,k,i) + qi_p(i,k,j) = qi(k,i) + qs_p(i,k,j) = qs(k,i) + qg_p(i,k,j) = qg(k,i) enddo enddo enddo @@ -459,81 +503,97 @@ subroutine microphysics_from_MPAS(mesh,state,tend,diag) end select microp_select_init +! write(0,*) '--- end subroutine microphysics_from_MPAS.' + !formats: - 201 format(3i6,10(1x,e15.8)) + 201 format(2i6,10(1x,e15.8)) end subroutine microphysics_from_MPAS !================================================================================================== - subroutine microphysics_to_MPAS(mesh,state,diag,tend,itimestep) + subroutine microphysics_to_MPAS(mesh,state,time_lev,diag,tend,itimestep) !================================================================================================== !input variables: integer,intent(in):: itimestep - type(mesh_type),intent(in):: mesh + integer,intent(in):: time_lev + type(mpas_pool_type),intent(in):: mesh !output variables: - type(state_type),intent(inout):: state - type(diag_type),intent(inout):: diag - type(tend_type),intent(inout):: tend - - real(kind=RKIND):: min_theta,min_thp,min_tp - real(kind=RKIND):: max_theta,max_thp,max_tp - real(kind=RKIND):: min_qv,min_qc,min_qr,min_qi,min_qs,min_qg - real(kind=RKIND):: max_qv,max_qc,max_qr,max_qi,max_qs,max_qg + type(mpas_pool_type),intent(inout):: state + type(mpas_pool_type),intent(inout):: diag + type(mpas_pool_type),intent(inout):: tend + +!local pointers: + integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg + real(kind=RKIND),dimension(:),pointer :: rdzw + real(kind=RKIND),dimension(:),pointer :: surface_pressure,tend_sfc_pressure + real(kind=RKIND),dimension(:,:),pointer :: zgrid + real(kind=RKIND),dimension(:,:),pointer :: zz,exner,exner_b,pressure_b,rtheta_p,rtheta_b + real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p + real(kind=RKIND),dimension(:,:),pointer :: rt_diabatic_tend + real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg + real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: integer:: icount integer:: i,k,j - real(kind=RKIND),dimension(:,:),pointer:: zz,exner,exner_b,pressure_b,rtheta_p,rtheta_b - real(kind=RKIND),dimension(:,:),pointer:: rho_zz,theta_m,pressure_p - real(kind=RKIND),dimension(:,:),pointer:: rt_diabatic_tend - -!ldf(2011-11-12): surface pressure. real(kind=RKIND):: rho1,rho2,tem1,tem2 - real(kind=RKIND),dimension(:),pointer:: rdzw - real(kind=RKIND),dimension(:),pointer:: sfc_pressure - real(kind=RKIND),dimension(:,:),pointer:: zgrid -!ldf end. !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine microphysics_to_MPAS:' +! write(0,*) +! write(0,*) '--- enter subroutine microphysics_to_MPAS:' !initialization: - zz => mesh % zz % array - zgrid => mesh % zgrid % array - exner => diag % exner % array - exner_b => diag % exner_base % array - pressure_b => diag % pressure_base % array - pressure_p => diag % pressure_p % array - rtheta_p => diag % rtheta_p % array - rtheta_b => diag % rtheta_base % array - - rho_zz => state % rho_zz % array - theta_m => state % theta_m % array - - rt_diabatic_tend => tend % rt_diabatic_tend % array - -!ldf (2011-11-12): update surface pressure. - rdzw => mesh % rdzw % array - sfc_pressure => diag % surface_pressure % array -!ldf end. - -!variables common to all cloud microphysics schemes: - - do j = jts, jte - do k = kts, kte - do i = its, ite + call mpas_pool_get_array(mesh,'rdzw' ,rdzw ) + call mpas_pool_get_array(mesh,'zz' ,zz ) + call mpas_pool_get_array(mesh,'zgrid',zgrid) + + call mpas_pool_get_array(diag,'exner' ,exner ) + call mpas_pool_get_array(diag,'exner_base' ,exner_b ) + call mpas_pool_get_array(diag,'pressure_base' ,pressure_b ) + call mpas_pool_get_array(diag,'pressure_p' ,pressure_p ) + call mpas_pool_get_array(diag,'rtheta_base' ,rtheta_b ) + call mpas_pool_get_array(diag,'rtheta_p' ,rtheta_p ) + call mpas_pool_get_array(diag,'surface_pressure',surface_pressure) + + call mpas_pool_get_array(tend,'tend_sfc_pressure',tend_sfc_pressure) + + call mpas_pool_get_array(state,'rho_zz' ,rho_zz ,time_lev) + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_dimension(state,'index_qc',index_qc) + call mpas_pool_get_dimension(state,'index_qr',index_qr) + call mpas_pool_get_dimension(state,'index_qi',index_qi) + call mpas_pool_get_dimension(state,'index_qs',index_qs) + call mpas_pool_get_dimension(state,'index_qg',index_qg) + + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + qv => scalars(index_qv,:,:) + qc => scalars(index_qc,:,:) + qr => scalars(index_qr,:,:) + qi => scalars(index_qi,:,:) + qs => scalars(index_qs,:,:) + qg => scalars(index_qg,:,:) + + call mpas_pool_get_array(tend,'rt_diabatic_tend',rt_diabatic_tend) + +!update variables needed in the dynamical core: + do j = jts,jte + do k = kts,kte + do i = its,ite + qv(k,i) = qv_p(i,k,j) + qc(k,i) = qc_p(i,k,j) + qr(k,i) = qr_p(i,k,j) !potential temperature and diabatic forcing: rt_diabatic_tend(k,i) = theta_m(k,i) theta_m(k,i) = th_p(i,k,j) * (1. + R_v/R_d * qv_p(i,k,j)) rt_diabatic_tend(k,i) = (theta_m(k,i) - rt_diabatic_tend(k,i)) / dt_dyn -! rt_diabatic_tend(k,i) = 0. - !density-weigthed perturbation potential temperature: + !density-weighted perturbation potential temperature: rtheta_p(k,i) = rho_zz(k,i) * theta_m(k,i) - rtheta_b(k,i) !exner function: @@ -541,33 +601,29 @@ subroutine microphysics_to_MPAS(mesh,state,diag,tend,itimestep) !pertubation pressure: pressure_p(k,i) = zz(k,i)*R_d*(exner(k,i)*rtheta_p(k,i) & - + (exner(k,i)-exner_b(k,i))*rtheta_b(k,i)) - - !mass mixing ratios: - state % scalars % array(state%index_qv,k,i) = qv_p(i,k,j) - state % scalars % array(state%index_qc,k,i) = qc_p(i,k,j) - state % scalars % array(state%index_qr,k,i) = qr_p(i,k,j) + + (exner(k,i)-exner_b(k,i))*rtheta_b(k,i)) enddo enddo enddo -!updates the surface pressure. +!updates the surface pressure and calculates the surface pressure tendency: do j = jts,jte do i = its,ite tem1 = zgrid(2,i)-zgrid(1,i) tem2 = zgrid(3,i)-zgrid(2,i) rho1 = rho_zz(1,i) * zz(1,i) * (1. + qv_p(i,1,j)) - rho2 = rho_zz(2,i) * zz(2,i) * (1. + qv_P(i,2,j)) - sfc_pressure(i) = 0.5*g*(zgrid(2,i)-zgrid(1,i)) & - * (rho1 + 0.5*(rho2-rho1)*tem1/(tem1+tem2)) - sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i) + rho2 = rho_zz(2,i) * zz(2,i) * (1. + qv_p(i,2,j)) + + tend_sfc_pressure(i) = surface_pressure(i) + surface_pressure(i) = 0.5*gravity*(zgrid(2,i)-zgrid(1,i)) & + * (rho1 + 0.5*(rho2-rho1)*tem1/(tem1+tem2)) + surface_pressure(i) = surface_pressure(i) + pressure_p(1,i) + pressure_b(1,i) + tend_sfc_pressure(i) = (surface_pressure(i)-tend_sfc_pressure(i)) / dt_dyn enddo enddo -!ldf end. !variables specific to different cloud microphysics schemes: - microp_select_init: select case(microp_scheme) case ("wsm6") @@ -575,12 +631,10 @@ subroutine microphysics_to_MPAS(mesh,state,diag,tend,itimestep) do j = jts, jte do k = kts, kte do i = its, ite - !mass mixing ratios: - state % scalars % array(state%index_qi,k,i) = qi_p(i,k,j) - state % scalars % array(state%index_qs,k,i) = qs_p(i,k,j) - state % scalars % array(state%index_qg,k,i) = qg_p(i,k,j) - + qi(k,i) = qi_p(i,k,j) + qs(k,i) = qs_p(i,k,j) + qg(k,i) = qg_p(i,k,j) enddo enddo enddo @@ -590,10 +644,12 @@ subroutine microphysics_to_MPAS(mesh,state,diag,tend,itimestep) end select microp_select_init !formats: - 201 format(3i6,10(1x,e15.8)) + 201 format(2i6,10(1x,e15.8)) + +! write(0,*) '--- end subroutine microphysics_to_MPAS' end subroutine microphysics_to_MPAS !================================================================================================== - end module mpas_atmphys_interface_nhyd + end module mpas_atmphys_interface !================================================================================================== diff --git a/src/core_atmosphere/physics/mpas_atmphys_landuse.F b/src/core_atmosphere/physics/mpas_atmphys_landuse.F index cfccc4678e..57ec4f5ef7 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_landuse.F +++ b/src/core_atmosphere/physics/mpas_atmphys_landuse.F @@ -11,11 +11,8 @@ !================================================================================================== module mpas_atmphys_landuse - use mpas_configure,only: input_landuse_data, & - config_sfc_albedo, & - config_frac_seaice, & - config_do_restart use mpas_dmpar + use mpas_kind_types use mpas_grid_types use mpas_atmphys_utilities @@ -26,7 +23,7 @@ module mpas_atmphys_landuse public:: landuse_init_forMPAS !global variables: - integer,public:: isice,iswater + integer,public:: isice,iswater,isurban integer,parameter:: frac_seaice = 0 ! = 1: treats seaice as fractional field. ! = 0: ice/no-ice flag. @@ -68,25 +65,47 @@ module mpas_atmphys_landuse !> - xicem is now initialized in physics_init. !> - xland is now initialized in physics_initialize_real and updated in physics_update_sst if !> needed. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-24. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-24. !> * added initialization of the background surface albedo over snow. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-10-19. - +!> Laura D. Fowler (laura@ucar.edu) / 2013-10-19. +!> * Modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * In subroutine landuse_init_forMPAS, added the definition of isurban as a function of the +!> input landuse data file. +!> Dominikus Heinzeller (IMK) / 2014-07-24. contains + !================================================================================================== - subroutine landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input) + subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_input) !================================================================================================== !input arguments: type(dm_info),intent(in):: dminfo - type(mesh_type),intent(in):: mesh - type(diag_physics_type),intent(in):: diag_physics - type(sfc_input_type) ,intent(in):: sfc_input + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: sfc_input integer,intent(in):: julday +!local pointers: + logical,pointer:: config_do_restart, & + config_frac_seaice, & + config_sfc_albedo + + character(len=StrKIND),pointer:: mminlu + + integer,pointer:: nCells + integer,dimension(:),pointer:: ivgtyp + integer,dimension(:),pointer:: landmask + + real(kind=RKIND),dimension(:),pointer:: latCell + real(kind=RKIND),dimension(:),pointer:: snoalb,snowc,xice + real(kind=RKIND),dimension(:),pointer:: albbck,embck,xicem,xland,z0 + real(kind=RKIND),dimension(:),pointer:: mavail,sfc_albedo,sfc_emiss,thc,znt + !local variables: character(len=StrKIND) :: lutype character(len=StrKIND):: mess @@ -98,45 +117,45 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input) integer:: ierr,istat integer:: ic,is,isn,lucats,lumatch,luseas - integer:: iCell,nCells + integer:: iCell integer:: julday_init - integer,dimension(:),pointer:: ivgtyp - integer,dimension(:),pointer:: landmask real(kind=RKIND):: li real(kind=RKIND),dimension(max_cats,max_seas):: albd,slmo,sfem,sfz0,therin,scfx,sfhc - real(kind=RKIND),dimension(:),pointer:: latCell - real(kind=RKIND),dimension(:),pointer:: snoalb,snowc,xice - real(kind=RKIND),dimension(:),pointer:: albbck,embck,xicem,xland,z0 - real(kind=RKIND),dimension(:),pointer:: mavail,sfc_albedo,sfc_emiss,thc,znt - !-------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) + call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfc_albedo' ,config_sfc_albedo ) + call mpas_pool_get_array(sfc_input,'mminlu',mminlu) + + call mpas_pool_get_dimension(mesh,'nCells',nCells) + + call mpas_pool_get_array(mesh,'latCell',latCell) + + call mpas_pool_get_array(sfc_input,'landmask' , landmask ) + call mpas_pool_get_array(sfc_input,'ivgtyp' , ivgtyp ) + call mpas_pool_get_array(sfc_input,'snoalb' , snoalb ) + call mpas_pool_get_array(sfc_input,'snowc' , snowc ) + call mpas_pool_get_array(sfc_input,'xice' , xice ) + call mpas_pool_get_array(sfc_input,'xland' , xland ) + call mpas_pool_get_array(sfc_input,'sfc_albbck', albbck ) + + call mpas_pool_get_array(diag_physics,'sfc_emibck', embck ) + call mpas_pool_get_array(diag_physics,'mavail' , mavail ) + call mpas_pool_get_array(diag_physics,'sfc_albedo', sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emiss' , sfc_emiss ) + call mpas_pool_get_array(diag_physics,'thc' , thc ) + call mpas_pool_get_array(diag_physics,'xicem' , xicem ) + call mpas_pool_get_array(diag_physics,'z0' , z0 ) + call mpas_pool_get_array(diag_physics,'znt' , znt ) + write(0,*) - write(0,*) '--- enter subroutine landuse_init_forMPAS: julian day=', julday +! write(0,*) '--- enter subroutine landuse_init_forMPAS: julian day=', julday write(0,*) '--- config_frac_seaice = ',config_frac_seaice write(0,*) '--- xice_threshold = ',xice_threshold - nCells = mesh % nCells - latCell => mesh % latCell % array - - landmask => sfc_input % landmask % array - ivgtyp => sfc_input % ivgtyp % array - snoalb => sfc_input % snoalb % array - snowc => sfc_input % snowc % array - xice => sfc_input % xice % array - xland => sfc_input % xland % array - albbck => sfc_input % sfc_albbck % array - - embck => diag_physics % sfc_emibck % array - mavail => diag_physics % mavail % array - sfc_albedo => diag_physics % sfc_albedo % array - sfc_emiss => diag_physics % sfc_emiss % array - thc => diag_physics % thc % array - xicem => diag_physics % xicem % array - z0 => diag_physics % z0 % array - znt => diag_physics % znt % array - !reads in the landuse properties from landuse.tbl: if(dminfo % my_proc_id == IO_NODE) then open(land_unit,file='LANDUSE.TBL',action='READ',status='OLD',iostat=istat) @@ -149,7 +168,7 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input) read(unit=land_unit,fmt='(a35)') lutype read(unit=land_unit,fmt=*) lucats,luseas - if(lutype .eq. input_landuse_data)then + if(lutype .eq. mminlu)then write(mess,*) ' landuse type = ' // trim (lutype) // ' found', lucats, & ' categories', luseas, ' seasons' call physics_message(mess) @@ -179,23 +198,28 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input) ! if(is .lt. luseas) write(0,*) enddo -!defines the index iswater and isice as a function of sfc_input_data: +!defines the index isurban, iswater and, isice as a function of sfc_input_data: sfc_input_select: select case(trim(lutype)) case('OLD') iswater = 7 isice = 11 + isurban = 1 case('USGS') iswater = 16 isice = 24 + isurban = 1 case('MODIFIED_IGBP_MODIS_NOAH') iswater = 17 isice = 15 + isurban = 13 case('SiB') iswater = 15 isice = 16 + isurban = 11 case('LW12') iswater = 2 isice = 3 + isurban = 1 case default end select sfc_input_select endif @@ -205,6 +229,7 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input) DM_BCAST_INTEGER(lucats) DM_BCAST_INTEGER(iswater) DM_BCAST_INTEGER(isice) + DM_BCAST_INTEGER(isurban) DM_BCAST_MACRO(albd) DM_BCAST_MACRO(slmo) DM_BCAST_MACRO(sfem) @@ -214,6 +239,7 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input) DM_BCAST_MACRO(scfx) write(0,*) '--- isice =',isice write(0,*) '--- iswater =',iswater + write(0,*) '--- isurban =',isurban if(config_do_restart) then write(0,*) '--- config_do_restart =', config_do_restart write(0,*) '--- skip the end of landuse_init_forMPAS' @@ -273,7 +299,7 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input) enddo - write(0,*) '--- end subroutine landuse_init_forMPAS' +! write(0,*) '--- end subroutine landuse_init_forMPAS' !formats: 101 format(i6,8(1x,e15.8)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F index 43a4deaa79..f745e28e88 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F @@ -13,14 +13,11 @@ !================================================================================================== module mpas_atmphys_lsm_noahinit - use mpas_configure, only: restart => config_do_restart, & - mminlu => input_landuse_data, & - mminsl => input_soil_data , & - input_sfc_albedo => config_sfc_snowalbedo use mpas_dmpar + use mpas_kind_types use mpas_grid_types - use mpas_atmphys_constants, grav => g + use mpas_atmphys_constants use mpas_atmphys_utilities !wrf physics use module_sf_noahlsm @@ -40,45 +37,66 @@ module mpas_atmphys_lsm_noahinit !> ----------------------------------------- !> noah_init_forMPAS: call lsminit from subroutine init_lsm (module mpas_atmphyse_driver_lsm.F). !> lsminit : main initialization subroutine for the NOAH 4-layer land surface scheme. +!> +!> add-ons and modifications to sourcecode: +!> ---------------------------------------- +!> * replaced the variable grav with gravity, for simplicity. +!> Laura D. Fowler (laura@ucar.edu) / 2014-03-21. +!> * added "use mpas_kind_types" at the top of the module. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. contains + !================================================================================================== - subroutine noah_init_forMPAS(dminfo,mesh,diag_physics,sfc_input) + subroutine noah_init_forMPAS(dminfo,mesh,configs,diag_physics,sfc_input) !================================================================================================== !input arguments: type(dm_info):: dminfo - type(mesh_type):: mesh + type(mpas_pool_type):: mesh + type(mpas_pool_type),intent(in):: configs !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(sfc_input_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input !-------------------------------------------------------------------------------------------------- !read formatted files needed for land-surface model: - call lsminit(dminfo,mesh,diag_physics,sfc_input) + call lsminit(dminfo,mesh,configs,diag_physics,sfc_input) end subroutine noah_init_forMPAS !================================================================================================== - subroutine lsminit(dminfo,mesh,diag_physics,sfc_input) + subroutine lsminit(dminfo,mesh,configs,diag_physics,sfc_input) !================================================================================================== !input arguments: type(dm_info),intent(in):: dminfo - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(sfc_input_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers:: + logical,pointer:: input_sfc_albedo,restart + + character(len=StrKIND),pointer:: mminlu,mminsl + + integer,pointer:: nCells,nSoilLevels + integer,dimension(:),pointer:: ivgtyp,isltyp + + real(kind=RKIND),dimension(:),pointer:: snoalb,snow,snowh + real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o !local variables: logical,parameter:: fndsnowh = .true. - integer:: iCell,nCells,nSoilLevels + integer:: iCell integer:: errflag,ns real(kind=RKIND):: bx,fk,smcmax,psisat,free @@ -86,23 +104,24 @@ subroutine lsminit(dminfo,mesh,diag_physics,sfc_input) real(kind=RKIND),parameter:: hlice = 3.335e5 real(kind=RKIND),parameter:: t0 = 273.15 - integer,dimension(:),pointer:: ivgtyp,isltyp - real(kind=RKIND),dimension(:),pointer:: snoalb,snow,snowh - real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o - !-------------------------------------------------------------------------------------------------- - nCells = mesh % nCells - nSoilLevels = mesh % nSoilLevels + call mpas_pool_get_array(sfc_input,'mminlu' ,mminlu ) + call mpas_pool_get_config(configs,'input_soil_data' ,mminsl ) + call mpas_pool_get_config(configs,'config_sfc_snowalbedo',input_sfc_albedo) + call mpas_pool_get_config(configs,'config_do_restart' ,restart ) + + call mpas_pool_get_dimension(mesh,'nCells' ,nCells ) + call mpas_pool_get_dimension(mesh,'nSoilLevels',nSoilLevels) - isltyp => sfc_input % isltyp % array - ivgtyp => sfc_input % ivgtyp % array - sh2o => sfc_input % sh2o % array - smois => sfc_input % smois % array - tslb => sfc_input % tslb % array - snoalb => sfc_input % snoalb % array - snow => sfc_input % snow % array - snowh => sfc_input % snowh % array + call mpas_pool_get_array(sfc_input,'isltyp', isltyp) + call mpas_pool_get_array(sfc_input,'ivgtyp', ivgtyp) + call mpas_pool_get_array(sfc_input,'sh2o' , sh2o ) + call mpas_pool_get_array(sfc_input,'smois' , smois ) + call mpas_pool_get_array(sfc_input,'tslb' , tslb ) + call mpas_pool_get_array(sfc_input,'snoalb', snoalb) + call mpas_pool_get_array(sfc_input,'snow' , snow ) + call mpas_pool_get_array(sfc_input,'snowh' , snowh ) !reads the NOAH LSM tables: call physics_message( ' initialize NOAH LSM tables' ) @@ -143,7 +162,7 @@ subroutine lsminit(dminfo,mesh,diag_physics,sfc_input) smcmax = maxsmc(isltyp(iCell)) psisat = satpsi(isltyp(iCell)) if(bx > blim) bx = blim - fk = (((hlice/(grav*(-psisat))) * & + fk = (((hlice/(gravity*(-psisat))) * & ((tslb(ns,iCell)-t0)/tslb(ns,iCell)) )**(-1/bx) )*smcmax if (fk < 0.02) fk = 0.02 sh2o(ns,iCell) = min(fk,smois(ns,iCell)) @@ -243,7 +262,7 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) call physics_message(mess) lumatch=1 else - call physics_message("skipping over lutype = " // trim ( lutype )) + call physics_message(' skipping over lutype = ' // trim ( lutype )) do lc = 1, lucats+12 read(16,*) enddo @@ -292,7 +311,7 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) 2002 continue close (16) if(lumatch == 0) & - call physics_error_fatal ("land use dataset '"//mminlu//"' not found in vegparm.tbl.") + call physics_error_fatal ('land use dataset '''//mminlu//''' not found in VEGPARM.TBL.') endif ! end dminfo diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index 526e7bfbda..b5d96683fd 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -7,10 +7,10 @@ ! !================================================================================================== module mpas_atmphys_manager - use mpas_configure use mpas_kind_types use mpas_grid_types use mpas_timekeeping + use mpas_stream_manager use mpas_atmphys_constants use mpas_atmphys_vars @@ -31,40 +31,40 @@ module mpas_atmphys_manager !defines alarms for calling the long- and short-wave radiation codes, for calling the convec- !tion scheme: - integer, parameter:: radtlwAlarmID = 11 - integer, parameter:: radtswAlarmID = 12 - integer, parameter:: convAlarmID = 13 - integer, parameter:: pblAlarmID = 14 + character(len=*), parameter:: radtlwAlarmID = 'radtlw' + character(len=*), parameter:: radtswAlarmID = 'radtsw' + character(len=*), parameter:: convAlarmID = 'conv' + character(len=*), parameter:: pblAlarmID = 'pbl' !defines alarm to update the surface boundary conditions: - integer, parameter:: sfcbdyAlarmID = 15 + character(len=*), parameter:: sfcbdyAlarmID = 'sfcbdy' !defines alarm to update the background surface albedo and the greeness fraction: - integer, parameter:: greenAlarmID = 16 + character(len=*), parameter:: greenAlarmID = 'green' !defines alarm to update the ozone path length,the trace gas path length,the total emissivity, !and the total absorptivity in the "CAM" long-wave radiation codes. The default time interval !between updates is 6 hours and is set with config_camrad_abs_update (00:30:00). - integer, parameter:: camAlarmID = 17 + character(len=*), parameter:: camAlarmID = 'cam' !defines alarm to save the CAM arrays absnst, absnxt, and emstot to restart files. When the !alarm rings, the local arrays absnt_p, absnxt_p, and emstot_p are copied to the MPAS arrays !for writing to restart files at the bottom of the time-step: - integer, parameter:: camlwAlarmID = 18 + character(len=*), parameter:: camlwAlarmID = 'camlw' type(MPAS_TimeInterval_Type):: camlwTimeStep !defines alarm to check if the accumulated rain due to cloud microphysics and convection is !greater than its maximum allowed value: - integer, parameter:: acrainAlarmID = 19 + character(len=*), parameter:: acrainAlarmID = 'acrain' type(MPAS_TimeInterval_Type):: acrainTimeStep !defines alarm to check if the accumulated radiation diagnostics due to long- and short-wave !radiation is greater than its maximum allowed value: - integer, parameter:: acradtAlarmID = 20 + character(len=*), parameter:: acradtAlarmID = 'acradt' type(MPAS_TimeInterval_Type):: acradtTimeStep !defines alarm to compute some physics diagnostics, such as radar reflectivity: - integer, parameter:: diagAlarmID = 21 + character(len=*), parameter:: diagAlarmID = 'diag' integer :: h, m, s, s_n, s_d, DoY, yr real(kind=RKIND) :: utc_h @@ -85,19 +85,24 @@ module mpas_atmphys_manager !> ---------------------------------------- !> * added initialization of variable sf_surface_physics in subroutine physics_run_init. see !> definition of sf_surface_physics in mpas_atmphys_vars.F -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-03-11. +!> Laura D. Fowler (laura@ucar.edu) / 2013-03-11. !> * removed the namelist option config_conv_shallow_scheme and associated sourcecode. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-05-29. +!> Laura D. Fowler (laura@ucar.edu) / 2013-05-29. !> * added call to subroutine o3climatology_from_MPAS to interpolate the climatological ozone !> mixing ratios to the current julian day. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-03. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-03. !> * added domain%dminfo in call to subroutine physics_update_sst to print local and global !> min and max values of the updated sea-surface temperatures and sea-ice fractions. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-24. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-24. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * renamed config_conv_deep_scheme to config_convection_scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. contains + !================================================================================================== subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) !================================================================================================== @@ -111,8 +116,31 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) type(MPAS_Clock_type),intent(inout):: clock type(domain_type),intent(inout) :: domain +!local pointers: + logical,pointer:: config_frac_seaice, & + config_o3climatology, & + config_sfc_albedo, & + config_sst_update, & + config_sstdiurn_update, & + config_deepsoiltemp_update + + character(len=StrKIND),pointer:: config_convection_scheme, & + config_radt_lw_scheme, & + config_radt_sw_scheme + + character(len=StrKIND),pointer:: config_conv_interval, & + config_radtlw_interval, & + config_radtsw_interval + + type(block_type),pointer :: block + type(mpas_pool_type),pointer:: mesh + type(mpas_pool_type),pointer:: configs + type(mpas_pool_type),pointer:: diag_physics + type(mpas_pool_type),pointer:: sfc_input + type(mpas_pool_type),pointer:: atm_input + !local variables: - type(block_type),pointer:: block + type(MPAS_Time_Type):: currTime type (MPAS_TimeInterval_type) :: dtInterval @@ -123,8 +151,23 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) real(kind=RKIND):: xtime_m !================================================================================================== - write(0,*) - write(0,*) '--- enter subroutine physics_timetracker: itimestep = ', itimestep +! write(0,*) +! write(0,*) '--- enter subroutine physics_timetracker: itimestep = ', itimestep + + call mpas_pool_get_config(domain%blocklist%configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(domain%blocklist%configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + + call mpas_pool_get_config(domain%blocklist%configs,'config_conv_interval' ,config_conv_interval ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radtlw_interval' ,config_radtlw_interval ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radtsw_interval' ,config_radtsw_interval ) + + call mpas_pool_get_config(domain%blocklist%configs,'config_frac_seaice' ,config_frac_seaice ) + call mpas_pool_get_config(domain%blocklist%configs,'config_o3climatology' ,config_o3climatology ) + call mpas_pool_get_config(domain%blocklist%configs,'config_sfc_albedo' ,config_sfc_albedo ) + call mpas_pool_get_config(domain%blocklist%configs,'config_sst_update' ,config_sst_update ) + call mpas_pool_get_config(domain%blocklist%configs,'config_sstdiurn_update' ,config_sstdiurn_update ) + call mpas_pool_get_config(domain%blocklist%configs,'config_deepsoiltemp_update',config_deepsoiltemp_update) !update the current julian day and current year: 100 format(' YEAR =', i5 ,/, & @@ -145,17 +188,23 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) julday = DoY curr_julday = real(julday-1) + utc_h / 24.0 LeapYear = isLeapYear(year) - write(0,100) year,julday,gmt,utc_h,curr_julday,LeapYear,timeStamp +! write(0,100) year,julday,gmt,utc_h,curr_julday,LeapYear,timeStamp block => domain % blocklist do while(associated(block)) + call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) + call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) + call mpas_pool_get_subpool(block%structs,'atm_input' ,atm_input ) + call mpas_pool_get_subpool(block%structs,'diag_physics',diag_physics) + + !update the background surface albedo and greeness of vegetation: interpolation of input !monthly values to current day: if(mpas_is_alarm_ringing(clock,greenAlarmID,ierr=ierr)) then call mpas_reset_clock_alarm(clock,greenAlarmID,ierr=ierr) write(0,*) '--- time to update background surface albedo, greeness fraction.' - call physics_update_surface(timeStamp,block%mesh,block%sfc_input) + call physics_update_surface(timeStamp,config_sfc_albedo,mesh,sfc_input) endif !update surface boundary conditions with input sea-surface temperatures and fractional @@ -163,17 +212,17 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) if(mpas_is_alarm_ringing(clock,sfcbdyAlarmID,ierr=ierr)) then call mpas_reset_clock_alarm(clock,sfcbdyAlarmID,ierr=ierr) if(config_sst_update) & - call physics_update_sst(domain%dminfo,block%mesh,block%sfc_input,block%diag_physics) + call physics_update_sst(domain%dminfo,config_frac_seaice,mesh,sfc_input,diag_physics) endif !apply a diurnal cycle to the sea-surface temperature: if(config_sstdiurn_update) & - call physics_update_sstskin(dt_dyn,block%mesh,block%diag_physics,block%sfc_input) + call physics_update_sstskin(dt_dyn,mesh,diag_physics,sfc_input) !update the deep soil temperature: if(config_deepsoiltemp_update) & - call physics_update_deepsoiltemp(LeapYear,dt_dyn,curr_julday,block%mesh, & - block%sfc_input,block%diag_physics) + call physics_update_deepsoiltemp(LeapYear,dt_dyn,curr_julday,mesh, & + sfc_input,diag_physics) block => block % next end do @@ -208,7 +257,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) endif !check to see if it is time to run the parameterization of convection: - if(trim(config_conv_deep_scheme) /= "off") then + if(trim(config_convection_scheme) /= "off") then l_conv = .false. if(config_conv_interval /= "none") then @@ -229,7 +278,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) if((l_radtlw .and. trim(config_radt_lw_scheme) .eq. "rrtmg_lw") .or. & l_radtsw .and. trim(config_radt_sw_scheme) .eq. "rrtmg_sw" ) then - call o3climatology_from_MPAS(curr_julday,block%mesh,block%atm_input,block%diag_physics) + call o3climatology_from_MPAS(curr_julday,mesh,atm_input,diag_physics) write(0,*) '--- time to update the ozone climatology for RRTMG radiation codes' endif @@ -263,7 +312,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) !check to see if it is time to apply limit to the accumulated rain due to cloud microphysics !and convection: - if(trim(config_conv_deep_scheme) /= "off") then + if(trim(config_convection_scheme) /= "off") then l_acrain = .false. if(mpas_is_alarm_ringing(clock,acrainAlarmID,acrainTimeStep,ierr=ierr)) then call mpas_reset_clock_alarm(clock,acrainAlarmID,acrainTimeStep,ierr=ierr) @@ -297,22 +346,88 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) end subroutine physics_timetracker !================================================================================================== - subroutine physics_run_init(mesh,state,clock) + subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh - type(state_type),intent(in):: state + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: state type(MPAS_Clock_type):: clock + type (MPAS_streamManager_type), intent(inout) :: stream_manager + +!local pointers: + character(len=StrKIND),pointer:: config_convection_scheme, & + config_gwdo_scheme, & + config_lsm_scheme, & + config_microp_scheme, & + config_pbl_scheme, & + config_radt_cld_scheme, & + config_radt_lw_scheme, & + config_radt_sw_scheme, & + config_sfclayer_scheme + + character(len=StrKIND),pointer:: config_conv_interval, & + config_pbl_interval, & + config_radtlw_interval, & + config_radtsw_interval, & + config_bucket_update, & + config_camrad_abs_update, & + config_greeness_update + + logical,pointer:: config_frac_seaice + + integer,pointer:: config_n_microp + integer,pointer:: cam_dim1 + integer,pointer:: nMonths + integer,pointer:: nAerosols,nAerLevels,nOznLevels + integer,pointer:: nCellsSolve,nSoilLevels,nVertLevels + + real(kind=RKIND),pointer:: config_dt !local variables: type(MPAS_Time_Type):: startTime,alarmStartTime type(MPAS_TimeInterval_Type):: alarmTimeStep, alarmTimeStepHi + character(len=StrKIND) :: stream_interval integer:: ierr !================================================================================================== - write(0,*) - write(0,*) '--- enter subroutine physics_run_init:' +! write(0,*) +! write(0,*) '--- enter subroutine physics_run_init:' + + call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(configs,'config_gwdo_scheme' ,config_gwdo_scheme ) + call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) + call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,config_pbl_scheme ) + call mpas_pool_get_config(configs,'config_radt_cld_scheme' ,config_radt_cld_scheme ) + call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) + call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) + + call mpas_pool_get_config(configs,'config_conv_interval' ,config_conv_interval ) + call mpas_pool_get_config(configs,'config_pbl_interval' ,config_pbl_interval ) + call mpas_pool_get_config(configs,'config_radtlw_interval' ,config_radtlw_interval ) + call mpas_pool_get_config(configs,'config_radtsw_interval' ,config_radtsw_interval ) + call mpas_pool_get_config(configs,'config_bucket_update' ,config_bucket_update ) + call mpas_pool_get_config(configs,'config_camrad_abs_update' ,config_camrad_abs_update ) + call mpas_pool_get_config(configs,'config_greeness_update' ,config_greeness_update ) + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice ) + call mpas_pool_get_config(configs,'config_n_microp' ,config_n_microp ) + + call mpas_pool_get_config(configs,'config_dt',config_dt) + + + call mpas_pool_get_dimension(mesh,'cam_dim1' ,cam_dim1 ) + call mpas_pool_get_dimension(mesh,'nMonths' ,nMonths ) + call mpas_pool_get_dimension(mesh,'nAerLevels' ,nAerLevels ) + call mpas_pool_get_dimension(mesh,'nOznLevels' ,nOznLevels ) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nSoilLevels',nSoilLevels) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) + + call mpas_pool_get_dimension(state,'num_aerosols',nAerosols) !initialization of gmt, julian day, and alarms: 101 format(' YEAR =', i5 ,/, & @@ -343,7 +458,7 @@ subroutine physics_run_init(mesh,state,clock) gmt = utc_h julday = DoY curr_julday = real(julday-1) - write(0,101) year,julday,gmt,utc_h,curr_julday +! write(0,101) year,julday,gmt,utc_h,curr_julday !set alarms for calling the longwave and shortwave radiation schemes, the convection schemes, !and the PBL schemes at intervals different (greater) than the dynamical time-step: @@ -432,8 +547,10 @@ subroutine physics_run_init(mesh,state,clock) call physics_error_fatal('subroutine physics_init: error creating alarm greeness') !set alarm for updating the surface boundary conditions: - if(trim(config_sfc_update_interval) /= "none") then - call mpas_set_timeInterval(alarmTimeStep,timeString=config_sfc_update_interval,ierr=ierr) + call MPAS_stream_mgr_get_property(stream_manager, 'surface', MPAS_STREAM_PROPERTY_RECORD_INTV, stream_interval, & + direction=MPAS_STREAM_INPUT, ierr=ierr) + if(trim(stream_interval) /= 'none') then + call mpas_set_timeInterval(alarmTimeStep,timeString=stream_interval,ierr=ierr) alarmStartTime = startTime call mpas_add_clock_alarm(clock,sfcbdyAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr) if(ierr /= 0) & @@ -455,11 +572,15 @@ subroutine physics_run_init(mesh,state,clock) !for writing to the restart file at the bottom of the time-step: if(trim(config_radt_lw_scheme) .eq. "cam_lw" ) then call mpas_set_timeInterval(camlwTimeStep,dt=config_dt,ierr=ierr) - call mpas_set_timeInterval(alarmTimeStep,timeString=config_restart_interval,ierr=ierr) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock,camlwAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr) - if(ierr /= 0) & - call physics_error_fatal('subroutine physics_init: error creating alarm CAMLW') + call MPAS_stream_mgr_get_property(stream_manager, 'restart', MPAS_STREAM_PROPERTY_RECORD_INTV, stream_interval, & + direction=MPAS_STREAM_OUTPUT, ierr=ierr) + if(trim(stream_interval) /= 'none') then + call mpas_set_timeInterval(alarmTimeStep,timeString=stream_interval,ierr=ierr) + alarmStartTime = startTime + alarmTimeStep + call mpas_add_clock_alarm(clock,camlwAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr) + if(ierr /= 0) & + call physics_error_fatal('subroutine physics_init: error creating alarm CAMLW') + endif endif !set alarm to check if the accumulated rain due to cloud microphysics and convection is @@ -485,22 +606,42 @@ subroutine physics_run_init(mesh,state,clock) endif !set alarm to calculate physics diagnostics on IO outpt only: - call mpas_set_timeInterval(alarmTimeStep,timeString=config_output_interval,ierr=ierr) - if (trim(config_hifreq_output_interval) /= 'none') then - call mpas_set_timeInterval(alarmTimeStepHi,timeString=config_hifreq_output_interval,ierr=ierr) - if (alarmTimeStepHi < alarmTimeStep) then - alarmTimeStep = alarmTimeStepHi + call MPAS_stream_mgr_get_property(stream_manager, 'output', MPAS_STREAM_PROPERTY_RECORD_INTV, stream_interval, & + direction=MPAS_STREAM_OUTPUT, ierr=ierr) + if(trim(stream_interval) /= 'none') then + call mpas_set_timeInterval(alarmTimeStep,timeString=stream_interval,ierr=ierr) + + ! If the diagnostic interval is higher in resolution, use it instead + call MPAS_stream_mgr_get_property(stream_manager, 'diagnostics', MPAS_STREAM_PROPERTY_RECORD_INTV, stream_interval, & + direction=MPAS_STREAM_OUTPUT, ierr=ierr) + if(trim(stream_interval) /= 'none') then + call mpas_set_timeInterval(alarmTimeStepHi,timeString=stream_interval,ierr=ierr) + if (alarmTimeStepHi < alarmTimeStep) then + alarmTimeStep = alarmTimeStepHi + end if end if - end if - alarmStartTime = startTime - call mpas_add_clock_alarm(clock,diagAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr) + alarmStartTime = startTime + call mpas_add_clock_alarm(clock,diagAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr) + if(ierr /= 0) & + call physics_error_fatal('subroutine physics_init: error creating alarm diag') + else + call MPAS_stream_mgr_get_property(stream_manager, 'diagnostics', MPAS_STREAM_PROPERTY_RECORD_INTV, stream_interval, & + direction=MPAS_STREAM_OUTPUT, ierr=ierr) + if(trim(stream_interval) /= 'none') then + call mpas_set_timeInterval(alarmTimeStep,timeString=stream_interval,ierr=ierr) + alarmStartTime = startTime + call mpas_add_clock_alarm(clock,diagAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr) + if(ierr /= 0) & + call physics_error_fatal('subroutine physics_init: error creating alarm diag') + end if + endif write(0,102) dt_radtlw,dt_radtsw,dt_cu,dt_pbl !initialization of physics dimensions to mimic a rectangular grid: - ims=1 ; ime = mesh % nCellsSolve + ims=1 ; ime = nCellsSolve jms=1 ; jme=1 - kms=1 ; kme = mesh % nVertLevels+1 + kms=1 ; kme = nVertLevels+1 ids=ims ; ide=ime jds=jms ; jde=jme @@ -515,18 +656,18 @@ subroutine physics_run_init(mesh,state,clock) its,ite,jts,jte,kts,kte !initialization local physics variables: - num_months = mesh % nMonths - num_soils = mesh% nSoilLevels - - conv_deep_scheme = trim(config_conv_deep_scheme) - lsm_scheme = trim(config_lsm_scheme) - microp_scheme = trim(config_microp_scheme) - pbl_scheme = trim(config_pbl_scheme) - gwdo_scheme = trim(config_gwdo_scheme) - radt_cld_scheme = trim(config_radt_cld_scheme) - radt_lw_scheme = trim(config_radt_lw_scheme) - radt_sw_scheme = trim(config_radt_sw_scheme) - sfclayer_scheme = trim(config_sfclayer_scheme) + num_months = nMonths + num_soils = nSoilLevels + + convection_scheme = trim(config_convection_scheme) + lsm_scheme = trim(config_lsm_scheme) + microp_scheme = trim(config_microp_scheme) + pbl_scheme = trim(config_pbl_scheme) + gwdo_scheme = trim(config_gwdo_scheme) + radt_cld_scheme = trim(config_radt_cld_scheme) + radt_lw_scheme = trim(config_radt_lw_scheme) + radt_sw_scheme = trim(config_radt_sw_scheme) + sfclayer_scheme = trim(config_sfclayer_scheme) if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 @@ -557,18 +698,24 @@ subroutine physics_run_init(mesh,state,clock) !radiation code. these arrays are calculated once if it is the beginning of a !new run or if it is a restart run: doabsems = .false. - cam_abs_dim1 = mesh % cam_dim1 - cam_abs_dim2 = mesh % nVertLevels + 1 + cam_abs_dim1 = cam_dim1 + cam_abs_dim2 = nVertLevels + 1 !initializes the number of aerosols, and the prescribed vertical dimensions for !aerosols and ozone mixing ratios: - num_aerosols = state % num_aerosols - num_aerLevels = mesh % naerLevels + write(0,*) + write(0,*) '--- doabsems = ',doabsems + write(0,*) '--- cam_abs_dim1 = ', cam_abs_dim1 + write(0,*) '--- cam_abs_dim2 = ', cam_abs_dim2 + write(0,*) '--- nAerosols = ', nAerosols + write(0,*) '--- naerLevels = ', naerLevels + num_aerosols = nAerosols + num_aerLevels = naerLevels endif !initialization of number of ozone levels: - num_oznlevels = mesh % noznLevels + num_oznlevels = noznLevels !initialization of sea-ice threshold: if(.not. config_frac_seaice) then diff --git a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F index f70bd79ca4..f0171546b9 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F +++ b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F @@ -45,13 +45,18 @@ module mpas_atmphys_o3climatology !> as in the CAM radiation codes. !> vinterp_ozn : vertical interpolation of the ozone volume mixing ratios from fixed !> ozone pressure levels to the MPAS pressure levels. - -!> modifications: -!> none. +!> +!> add-ons and modifications to sourcecode: +!> ---------------------------------------- +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. contains + !================================================================================================== subroutine init_o3climatology(mesh,atm_input) !================================================================================================== @@ -60,10 +65,16 @@ subroutine init_o3climatology(mesh,atm_input) !with monthly climatology varying ozone distribution. !input arguments: - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh !inout arguments: - type(atm_input_type), intent(inout):: atm_input + type(mpas_pool_type),intent(inout):: atm_input + +!local pointers: + integer, pointer:: nCells,num_months,levsiz + real(kind=RKIND),dimension(:),pointer:: latCell,lonCell + real(kind=RKIND),dimension(:),pointer:: pin + real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm !local variables: integer,parameter:: pin_unit = 27 @@ -72,28 +83,24 @@ subroutine init_o3climatology(mesh,atm_input) integer,parameter:: open_ok = 0 integer:: i,i1,i2,istat,k,j,m - integer:: iCell,nCells,num_months,levsiz + integer:: iCell - real(kind=RKIND),dimension(:),pointer:: latCell,lonCell - real(kind=RKIND),dimension(:),pointer:: pin - real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm - real(kind=RKIND):: lat,lon,dlat,dlatCell real(kind=RKIND),dimension(latsiz):: lat_ozone -!real(Kind=RKIND),dimension(lonsiz,levsiz,latsiz,num_months):: ozmixin real(kind=RKIND),dimension(:,:,:,:),allocatable:: ozmixin !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine physics_init_o3:' +! write(0,*) +! write(0,*) '--- enter subroutine physics_init_o3:' + + call mpas_pool_get_dimension(mesh,'nCells',nCells) + call mpas_pool_get_dimension(mesh,'nMonths',num_months) + call mpas_pool_get_dimension(mesh,'nOznLevels',levsiz) - nCells = mesh % nCells - num_months = mesh % nMonths - levsiz = mesh % nOznLevels - pin => atm_input % pin % array - ozmixm => atm_input % ozmixm % array - latCell => mesh % latCell % array - lonCell => mesh % lonCell % array + call mpas_pool_get_array(atm_input,'pin',pin) + call mpas_pool_get_array(atm_input,'ozmixm',ozmixm) + call mpas_pool_get_array(mesh,'latCell',latCell) + call mpas_pool_get_array(mesh,'lonCell',lonCell) !-- read in ozone pressure data: open(pin_unit,file='OZONE_PLEV.TBL',action='READ',status='OLD',iostat=istat) @@ -180,7 +187,7 @@ subroutine init_o3climatology(mesh,atm_input) enddo deallocate(ozmixin) - write(0,*) '--- end subroutine physics_init_o3.' +! write(0,*) '--- end subroutine physics_init_o3.' !formats: 101 format(i3,12(1x,e15.8)) @@ -193,32 +200,35 @@ subroutine update_o3climatology(current_date,mesh,atm_input,diag_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh + type(mpas_pool_type),intent(in) :: mesh character(len=*),intent(in):: current_date !inout arguments: - type(atm_input_type),intent(inout):: atm_input - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: atm_input + type(mpas_pool_type),intent(inout):: diag_physics -!local variables: - integer:: iCell,iLev,nCellsSolve,nOznLevels +!local pointers: + integer, pointer:: nCellsSolve,nOznLevels real(kind=RKIND),dimension(:,:),pointer :: o3clim real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm +!local variables: + integer:: iCell,iLev + !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine physics_update_o3:' +! write(0,*) +! write(0,*) '--- enter subroutine physics_update_o3:' - nCellsSolve = mesh % nCellsSolve - nOznLevels = mesh % nOznLevels + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nOznLevels',nOznLevels) - ozmixm => atm_input % ozmixm % array - o3clim => diag_physics % o3clim % array + call mpas_pool_get_array(atm_input,'ozmixm',ozmixm) + call mpas_pool_get_array(diag_physics,'o3clim',o3clim) do iLev = 1,nOznLevels call monthly_interp_to_date(nCellsSolve,current_date,ozmixm(:,iLev,:),o3clim(iLev,:)) enddo - write(0,*) '--- end subroutine physics_update_o3:' +! write(0,*) '--- end subroutine physics_update_o3:' end subroutine update_o3climatology @@ -227,18 +237,23 @@ subroutine o3climatology_from_MPAS(julian,mesh,atm_input,diag_physics) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh real(kind=RKIND),intent(in):: julian - type(atm_input_type),intent(in):: atm_input + type(mpas_pool_type),intent(in):: atm_input !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + integer,pointer:: nOznLevels,nVertLevels,nCellsSolve,nMonths + real(kind=RKIND),dimension(:,:),pointer :: o3clim + real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm !local variables: logical:: finddate logical:: ozncyc - integer:: iCell,k,nCellsSolve,nVertLevels,nOznLevels,nMonths + integer:: iCell,k integer:: ijul,m,nm,np,np1 integer, dimension(12) :: date_oz data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/ @@ -253,10 +268,13 @@ subroutine o3climatology_from_MPAS(julian,mesh,atm_input,diag_physics) !write(0,*) !write(0,*) '--- enter subroutine o3climatology_from_MPAS:' - nOznLevels = mesh % nOznLevels - nVertLevels = mesh % nVertLevels - nCellsSolve = mesh % nCellsSolve - nMonths = mesh % nMonths + call mpas_pool_get_dimension(mesh,'nOznLevels',nOznLevels) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nMonths',nMonths) + + call mpas_pool_get_array(atm_input,'ozmixm',ozmixm) + call mpas_pool_get_array(diag_physics,'o3clim',o3clim) ozncyc = .true. @@ -301,12 +319,10 @@ subroutine o3climatology_from_MPAS(julian,mesh,atm_input,diag_physics) !Time interpolation. do k = 1, nOznLevels do iCell = 1, nCellsSolve - diag_physics % o3clim % array(k,iCell) = fact1 * atm_input % ozmixm % array(nm,k,iCell) & - + fact2 * atm_input % ozmixm % array(np,k,iCell) + o3clim(k,iCell) = fact1 * ozmixm(nm,k,iCell) + fact2 * ozmixm(np,k,iCell) end do -!write(0,101) k,diag_physics%o3clim%array(k,1),atm_input%ozmixm%array(nm,k,1), & -! atm_input%ozmixm%array(np,k,1),diag_physics%o3clim%array(k,nCellsSolve), & -! atm_input%ozmixm%array(nm,k,nCellsSolve),atm_input%ozmixm%array(np,k,nCellsSolve) +!write(0,101) k,o3clim(k,1),ozmixm(nm,k,1),ozmixm(np,k,1), & +! o3clim(k,nCellsSolve),ozmixm(nm,k,nCellsSolve),ozmixm(np,k,nCellsSolve) end do 101 format(i4,6(1x,e15.8)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 064a2d8189..fb3c53ac86 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -7,8 +7,9 @@ ! !================================================================================================== module mpas_atmphys_todynamics - use mpas_configure + use mpas_kind_types use mpas_grid_types + use mpas_dmpar use mpas_atmphys_constants, only: R_d,R_v,degrad @@ -27,36 +28,48 @@ module mpas_atmphys_todynamics !> --------------------------------------- !> physics_addtend: add and mass-weigh tendencies before being added to dynamics tendencies. !> tend_toEdges : interpolate wind-tendencies from centers to edges of grid-cells. +!> +!> add-ons and modifications to sourcecode: +!> ---------------------------------------- +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * renamed config_conv_deep_scheme to config_convection_scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. contains + !================================================================================================== - subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edge, rk_step) + subroutine physics_addtend(block, mesh, state, diag, tend, tend_physics, configs, rk_step) !================================================================================================== !input variables: !---------------- - type(mesh_type),intent(in):: mesh - type(state_type),intent(in):: state - type(diag_type),intent(in):: diag - type(tend_physics_type),intent(inout):: tend_physics + type(block_type),intent(in),target:: block + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(in):: configs integer, intent(in):: rk_step - real(kind=RKIND),dimension(:,:),intent(in):: mass - real(kind=RKIND),dimension(:,:),intent(in):: mass_edge !inout variables: !---------------- - type(tend_type),intent(inout):: tend + type(mpas_pool_type),intent(inout):: tend !local variables: !---------------- - - type(block_type),pointer :: block - - integer:: i,iCell,k,n,nCells,nCellsSolve,nEdges,nEdgesSolve,nVertLevels - - real(kind=RKIND),dimension(:,:),pointer:: theta_m,qv + integer:: i,iCell,k,n + integer,pointer:: index_qv, index_qc, index_qr, index_qi, index_qs, index_qg + integer,pointer:: nCells,nCellsSolve,nEdges,nEdgesSolve,nVertLevels + + real(kind=RKIND),dimension(:,:),pointer:: mass ! time level 2 rho_zz + real(kind=RKIND),dimension(:,:),pointer:: mass_edge ! diag rho_edge + real(kind=RKIND),dimension(:,:),pointer:: theta_m,qv ! time level 1 + real(kind=RKIND),dimension(:,:,:),pointer:: scalars real(kind=RKIND),dimension(:,:),pointer:: rthblten,rqvblten,rqcblten, & rqiblten,rublten,rvblten real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, & @@ -64,64 +77,91 @@ subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edg rucuten,rvcuten real(kind=RKIND),dimension(:,:),pointer:: rthratenlw,rthratensw - real(kind=RKIND),dimension(:,:),pointer :: tend_theta,tend_u + real(kind=RKIND),dimension(:,:),pointer:: tend_theta,tend_u real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars + real(kind=RKIND),dimension(:,:),pointer:: tend_qv,tend_qc,tend_qr,tend_qi,tend_qs,tend_qg real(kind=RKIND):: tem real(kind=RKIND),dimension(:,:),allocatable:: rublten_Edge,rucuten_Edge + character(len=StrKIND), pointer :: config_pbl_scheme, config_convection_scheme, & + config_radt_lw_scheme, config_radt_sw_scheme + !ldf (2011-12-16): real(kind=RKIND),dimension(:,:),allocatable:: theta,tend_th !ldf end. !================================================================================================== - block => mesh % block - - nCells = mesh % nCells - nEdges = mesh % nEdges - nCellsSolve = mesh % nCellsSolve - nEdgesSolve = mesh % nEdgesSolve - nVertLevels = mesh % nVertLevels - -!theta => diag % theta % array - theta_m => state % theta_m % array - qv => state % scalars % array(state%index_qv,:,:) - - rublten => tend_physics % rublten % array - rvblten => tend_physics % rvblten % array - rthblten => tend_physics % rthblten % array - rqvblten => tend_physics % rqvblten % array - rqcblten => tend_physics % rqcblten % array - rqiblten => tend_physics % rqiblten % array - - rucuten => tend_physics % rucuten % array - rvcuten => tend_physics % rvcuten % array - rthcuten => tend_physics % rthcuten % array - rqvcuten => tend_physics % rqvcuten % array - rqccuten => tend_physics % rqccuten % array - rqrcuten => tend_physics % rqrcuten % array - rqicuten => tend_physics % rqicuten % array - rqscuten => tend_physics % rqscuten % array - - rthratenlw => tend_physics % rthratenlw % array - rthratensw => tend_physics % rthratensw % array - - tend_u => tend % u % array - tend_theta => tend % theta_m % array - tend_scalars => tend % scalars % array + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_config(configs, 'config_pbl_scheme', config_pbl_scheme) + call mpas_pool_get_config(configs, 'config_convection_scheme', config_convection_scheme) + call mpas_pool_get_config(configs, 'config_radt_lw_scheme', config_radt_lw_scheme) + call mpas_pool_get_config(configs, 'config_radt_sw_scheme', config_radt_sw_scheme) + + call mpas_pool_get_array(state, 'theta_m', theta_m, 1) + call mpas_pool_get_array(state, 'scalars', scalars, 1) + call mpas_pool_get_array(state, 'rho_zz', mass, 2) + call mpas_pool_get_array(diag , 'rho_edge', mass_edge) + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_qc', index_qc) + call mpas_pool_get_dimension(state, 'index_qr', index_qr) + call mpas_pool_get_dimension(state, 'index_qi', index_qi) + call mpas_pool_get_dimension(state, 'index_qs', index_qs) + call mpas_pool_get_dimension(state, 'index_qg', index_qg) + qv => scalars(index_qv,:,:) + + call mpas_pool_get_array(tend_physics, 'rublten', rublten) + call mpas_pool_get_array(tend_physics, 'rvblten', rvblten) + call mpas_pool_get_array(tend_physics, 'rthblten', rthblten) + call mpas_pool_get_array(tend_physics, 'rqvblten', rqvblten) + call mpas_pool_get_array(tend_physics, 'rqcblten', rqcblten) + call mpas_pool_get_array(tend_physics, 'rqiblten', rqiblten) + + call mpas_pool_get_array(tend_physics, 'rucuten', rucuten) + call mpas_pool_get_array(tend_physics, 'rvcuten', rvcuten) + call mpas_pool_get_array(tend_physics, 'rthcuten', rthcuten) + call mpas_pool_get_array(tend_physics, 'rqvcuten', rqvcuten) + call mpas_pool_get_array(tend_physics, 'rqccuten', rqccuten) + call mpas_pool_get_array(tend_physics, 'rqrcuten', rqrcuten) + call mpas_pool_get_array(tend_physics, 'rqicuten', rqicuten) + call mpas_pool_get_array(tend_physics, 'rqscuten', rqscuten) + + call mpas_pool_get_array(tend_physics, 'rthratenlw', rthratenlw) + call mpas_pool_get_array(tend_physics, 'rthratensw', rthratensw) + + call mpas_pool_get_array(tend, 'u', tend_u) + call mpas_pool_get_array(tend, 'theta_m', tend_theta) + call mpas_pool_get_array(tend, 'scalars_tend', tend_scalars) + tend_qv => tend_scalars(index_qv,:,:) + tend_qc => tend_scalars(index_qc,:,:) + tend_qr => tend_scalars(index_qr,:,:) + tend_qi => tend_scalars(index_qi,:,:) + tend_qs => tend_scalars(index_qs,:,:) + tend_qg => tend_scalars(index_qg,:,:) !initialize the tendency for the potential temperature and all scalars due to PBL, convection, !and longwave and shortwave radiation: allocate(theta(nVertLevels,nCellsSolve) ) allocate(tend_th(nVertLevels,nCellsSolve)) - tend_th = 0. - tend_scalars = 0. + tend_th = 0._RKIND + tend_qv = 0._RKIND + tend_qc = 0._RKIND + tend_qr = 0._RKIND + tend_qi = 0._RKIND + tend_qs = 0._RKIND + tend_qg = 0._RKIND !add coupled tendencies due to PBL processes: if(config_pbl_scheme .ne. 'off') then allocate(rublten_Edge(nVertLevels,nEdges)) rublten_Edge(:,:) = 0. - call tend_toEdges(mesh,rublten,rvblten,rublten_Edge) + call tend_toEdges(block,mesh,rublten,rvblten,rublten_Edge) do i = 1, nEdgesSolve do k = 1, nVertLevels tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i) @@ -131,21 +171,21 @@ subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edg do i = 1, nCellsSolve do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i)+rthblten(k,i)*mass(k,i) - tend_scalars(tend%index_qv,k,i)=tend_scalars(tend%index_qv,k,i)+rqvblten(k,i)*mass(k,i) - tend_scalars(tend%index_qc,k,i)=tend_scalars(tend%index_qc,k,i)+rqcblten(k,i)*mass(k,i) - tend_scalars(tend%index_qi,k,i)=tend_scalars(tend%index_qi,k,i)+rqiblten(k,i)*mass(k,i) + tend_th(k,i) = tend_th(k,i) + rthblten(k,i)*mass(k,i) + tend_qv(k,i) = tend_qv(k,i) + rqvblten(k,i)*mass(k,i) + tend_qc(k,i) = tend_qc(k,i) + rqcblten(k,i)*mass(k,i) + tend_qi(k,i) = tend_qi(k,i) + rqiblten(k,i)*mass(k,i) enddo enddo endif !add coupled tendencies due to convection: - if(config_conv_deep_scheme .ne. 'off') then + if(config_convection_scheme .ne. 'off') then - if(config_conv_deep_scheme .eq. 'tiedtke') then + if(config_convection_scheme .eq. 'tiedtke') then allocate(rucuten_Edge(nVertLevels,nEdges)) rucuten_Edge(:,:) = 0. - call tend_toEdges(mesh,rucuten,rvcuten,rucuten_Edge) + call tend_toEdges(block,mesh,rucuten,rvcuten,rucuten_Edge) do i = 1, nEdgesSolve do k = 1, nVertLevels tend_u(k,i)=tend_u(k,i)+rucuten_Edge(k,i)*mass_edge(k,i) @@ -156,12 +196,12 @@ subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edg do i = 1, nCellsSolve do k = 1, nVertLevels - tend_th(k,i)=tend_th(k,i)+rthcuten(k,i)*mass(k,i) - tend_scalars(tend%index_qv,k,i)=tend_scalars(tend%index_qv,k,i)+rqvcuten(k,i)*mass(k,i) - tend_scalars(tend%index_qc,k,i)=tend_scalars(tend%index_qc,k,i)+rqccuten(k,i)*mass(k,i) - tend_scalars(tend%index_qr,k,i)=tend_scalars(tend%index_qr,k,i)+rqrcuten(k,i)*mass(k,i) - tend_scalars(tend%index_qi,k,i)=tend_scalars(tend%index_qi,k,i)+rqicuten(k,i)*mass(k,i) - tend_scalars(tend%index_qs,k,i)=tend_scalars(tend%index_qs,k,i)+rqscuten(k,i)*mass(k,i) + tend_th(k,i) = tend_th(k,i) + rthcuten(k,i)*mass(k,i) + tend_qv(k,i) = tend_qv(k,i) + rqvcuten(k,i)*mass(k,i) + tend_qc(k,i) = tend_qc(k,i) + rqccuten(k,i)*mass(k,i) + tend_qr(k,i) = tend_qr(k,i) + rqrcuten(k,i)*mass(k,i) + tend_qi(k,i) = tend_qi(k,i) + rqicuten(k,i)*mass(k,i) + tend_qs(k,i) = tend_qs(k,i) + rqscuten(k,i)*mass(k,i) enddo enddo endif @@ -170,7 +210,7 @@ subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edg if(config_radt_lw_scheme .ne. 'off') then do i = 1, nCellsSolve do k = 1, nVertLevels - tend_th(k,i)=tend_th(k,i)+rthratenlw(k,i)*mass(k,i) + tend_th(k,i) = tend_th(k,i) + rthratenlw(k,i)*mass(k,i) enddo enddo endif @@ -179,7 +219,7 @@ subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edg if(config_radt_sw_scheme .ne. 'off') then do i = 1, nCellsSolve do k = 1, nVertLevels - tend_th(k,i)=tend_th(k,i)+rthratensw(k,i)*mass(k,i) + tend_th(k,i) = tend_th(k,i) + rthratensw(k,i)*mass(k,i) enddo enddo endif @@ -190,7 +230,7 @@ subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edg do k = 1, nVertLevels theta(k,i) = theta_m(k,i) / (1. + R_v/R_d * qv(k,i)) tend_th(k,i) = (1. + R_v/R_d * qv(k,i)) * tend_th(k,i) & - + R_v/R_d * theta(k,i) * tend_scalars(tend%index_qv,k,i) + + R_v/R_d * theta(k,i) * tend_qv(k,i) tend_theta(k,i) = tend_theta(k,i) + tend_th(k,i) enddo enddo @@ -198,18 +238,18 @@ subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edg deallocate(tend_th) if(rk_step .eq. 3) then - write(0,*) - write(0,*) '--- enter subroutine physics_addtend:' - write(0,*) 'max rthblten = ',maxval(rthblten(:,1:nCellsSolve)) - write(0,*) 'min rthblten = ',minval(rthblten(:,1:nCellsSolve)) - write(0,*) 'max rthcuten = ',maxval(rthcuten(:,1:nCellsSolve)) - write(0,*) 'min rthcuten = ',minval(rthcuten(:,1:nCellsSolve)) - write(0,*) 'max rthratenlw = ',maxval(rthratenlw(:,1:nCellsSolve)) - write(0,*) 'min rthratenlw = ',minval(rthratenlw(:,1:nCellsSolve)) - write(0,*) 'max rthratensw = ',maxval(rthratensw(:,1:nCellsSolve)) - write(0,*) 'min rthratensw = ',minval(rthratensw(:,1:nCellsSolve)) - write(0,*) '--- end subroutine physics_addtend' - write(0,*) +! write(0,*) +! write(0,*) '--- enter subroutine physics_addtend:' +! write(0,*) 'max rthblten = ',maxval(rthblten(:,1:nCellsSolve)) +! write(0,*) 'min rthblten = ',minval(rthblten(:,1:nCellsSolve)) +! write(0,*) 'max rthcuten = ',maxval(rthcuten(:,1:nCellsSolve)) +! write(0,*) 'min rthcuten = ',minval(rthcuten(:,1:nCellsSolve)) +! write(0,*) 'max rthratenlw = ',maxval(rthratenlw(:,1:nCellsSolve)) +! write(0,*) 'min rthratenlw = ',minval(rthratenlw(:,1:nCellsSolve)) +! write(0,*) 'max rthratensw = ',maxval(rthratensw(:,1:nCellsSolve)) +! write(0,*) 'min rthratensw = ',minval(rthratensw(:,1:nCellsSolve)) +! write(0,*) '--- end subroutine physics_addtend' +! write(0,*) endif !formats: @@ -219,12 +259,13 @@ subroutine physics_addtend(mesh, state, diag, tend, tend_physics, mass, mass_edg end subroutine physics_addtend !================================================================================================== - subroutine tend_toEdges(mesh,Ux_tend,Uy_tend,U_tend) + subroutine tend_toEdges(block,mesh,Ux_tend,Uy_tend,U_tend) !================================================================================================== !input arguments: !---------------- - type(mesh_type),intent(in):: mesh + type(block_type),intent(in),target:: block + type(mpas_pool_type),intent(in):: mesh real(kind=RKIND),intent(in),dimension(:,:):: Ux_tend,Uy_tend !output arguments: @@ -233,10 +274,10 @@ subroutine tend_toEdges(mesh,Ux_tend,Uy_tend,U_tend) !local variables: !----------------- - type(block_type),pointer :: block type (field2DReal), pointer :: tempField type (field2DReal), target :: tempFieldTarget - integer:: iCell,iEdge,k,j,nCells,nCellsSolve,nVertLevels + integer:: iCell,iEdge,k,j + integer,pointer:: nCells,nCellsSolve,nVertLevels integer,dimension(:),pointer :: nEdgesOnCell integer,dimension(:,:),pointer:: edgesOnCell @@ -245,17 +286,15 @@ subroutine tend_toEdges(mesh,Ux_tend,Uy_tend,U_tend) !-------------------------------------------------------------------------------------------------- - block => mesh % block - - nCells = mesh % nCells - nCellsSolve = mesh % nCellsSolve - nVertLevels = mesh % nVertLevels - - east => mesh % east % array - north => mesh % north % array - edgesOnCell => mesh % edgesOnCell % array - nEdgesOnCell => mesh % nEdgesOnCell % array - edge_normal => mesh % edgeNormalVectors % array + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(mesh, 'east', east) + call mpas_pool_get_array(mesh, 'north', north) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'edgeNormalVectors', edge_normal) allocate(Ux_tend_halo(nVertLevels,nCells+1)) allocate(Uy_tend_halo(nVertLevels,nCells+1)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_update.F b/src/core_atmosphere/physics/mpas_atmphys_update.F index d974877bb0..e369743dae 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_update.F +++ b/src/core_atmosphere/physics/mpas_atmphys_update.F @@ -7,10 +7,10 @@ ! !================================================================================================== module mpas_atmphys_update - use mpas_configure + use mpas_kind_types use mpas_grid_types - use mpas_atmphys_driver_convection_deep + use mpas_atmphys_driver_convection use mpas_atmphys_vars implicit none @@ -29,9 +29,19 @@ module mpas_atmphys_update !> ----------------------------------- !> physics_update : not used. !> update_radiation_diagnostics: update accumulated radiation diagnostics. +!> +!> add-ons and modifications to sourcecode: +!> ---------------------------------------- +!> * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +!> Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +!> * renamed config_conv_deep_scheme to config_convection_scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. contains + !================================================================================================== subroutine physics_update(domain,dt) @@ -47,8 +57,8 @@ subroutine physics_update(domain,dt) !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- begin physics_update:' +! write(0,*) +! write(0,*) '--- begin physics_update:' block => domain % blocklist do while(associated(block)) @@ -57,115 +67,187 @@ subroutine physics_update(domain,dt) block => block % next end do - write(0,*) '--- end physics_update:' +! write(0,*) '--- end physics_update:' end subroutine physics_update !================================================================================================== - subroutine update_radiation_diagnostics(bucket_radt,mesh,diag) + subroutine update_radiation_diagnostics(configs,mesh,diag_physics) !================================================================================================== !input arguments: - real(kind=RKIND),intent(in):: bucket_radt - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh !inout arguments: - type(diag_physics_type),intent(inout):: diag + type(mpas_pool_type),intent(inout):: diag_physics -!local variables: +!local pointers: + integer,pointer:: nCellsSolve + integer,dimension(:),pointer :: i_acswdnb,i_acswdnbc,i_acswdnt,i_acswdntc, & + i_acswupb,i_acswupbc,i_acswupt,i_acswuptc, & + i_aclwdnb,i_aclwdnbc,i_aclwdnt,i_aclwdntc, & + i_aclwupb,i_aclwupbc,i_aclwupt,i_aclwuptc + + real(kind=RKIND),pointer:: bucket_radt + real(kind=RKIND),dimension(:),pointer:: swdnb,swdnbc,swdnt,swdntc, & + swupb,swupbc,swupt,swuptc, & + lwdnb,lwdnbc,lwdnt,lwdntc, & + lwupb,lwupbc,lwupt,lwuptc + real(kind=RKIND),dimension(:),pointer:: acswdnb,acswdnbc,acswdnt,acswdntc, & + acswupb,acswupbc,acswupt,acswuptc, & + aclwdnb,aclwdnbc,aclwdnt,aclwdntc, & + aclwupb,aclwupbc,aclwupt,aclwuptc + +!local variables and arrays: integer:: iCell !-------------------------------------------------------------------------------------------------- - do iCell = 1, mesh%nCellsSolve + call mpas_pool_get_config(configs,'config_bucket_radt',bucket_radt) + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + + call mpas_pool_get_array(diag_physics,'i_acswdnb' , i_acswdnb ) + call mpas_pool_get_array(diag_physics,'i_acswdnbc', i_acswdnbc) + call mpas_pool_get_array(diag_physics,'i_acswdnt' , i_acswdnt ) + call mpas_pool_get_array(diag_physics,'i_acswdntc', i_acswdntc) + call mpas_pool_get_array(diag_physics,'i_acswupb' , i_acswupb ) + call mpas_pool_get_array(diag_physics,'i_acswupbc', i_acswupbc) + call mpas_pool_get_array(diag_physics,'i_acswupt' , i_acswupt ) + call mpas_pool_get_array(diag_physics,'i_acswuptc', i_acswuptc) + call mpas_pool_get_array(diag_physics,'i_aclwdnb' , i_aclwdnb ) + call mpas_pool_get_array(diag_physics,'i_aclwdnbc', i_aclwdnbc) + call mpas_pool_get_array(diag_physics,'i_aclwdnt' , i_aclwdnt ) + call mpas_pool_get_array(diag_physics,'i_aclwdntc', i_aclwdntc) + call mpas_pool_get_array(diag_physics,'i_aclwupb' , i_aclwupb ) + call mpas_pool_get_array(diag_physics,'i_aclwupbc', i_aclwupbc) + call mpas_pool_get_array(diag_physics,'i_aclwupt' , i_aclwupt ) + call mpas_pool_get_array(diag_physics,'i_aclwuptc', i_aclwuptc) + + call mpas_pool_get_array(diag_physics,'acswdnb' , acswdnb ) + call mpas_pool_get_array(diag_physics,'acswdnbc' , acswdnbc ) + call mpas_pool_get_array(diag_physics,'acswdnt' , acswdnt ) + call mpas_pool_get_array(diag_physics,'acswdntc' , acswdntc ) + call mpas_pool_get_array(diag_physics,'acswupb' , acswupb ) + call mpas_pool_get_array(diag_physics,'acswupbc' , acswupbc ) + call mpas_pool_get_array(diag_physics,'acswupt' , acswupt ) + call mpas_pool_get_array(diag_physics,'acswuptc' , acswuptc ) + call mpas_pool_get_array(diag_physics,'aclwdnb' , aclwdnb ) + call mpas_pool_get_array(diag_physics,'aclwdnbc' , aclwdnbc ) + call mpas_pool_get_array(diag_physics,'aclwdnt' , aclwdnt ) + call mpas_pool_get_array(diag_physics,'aclwdntc' , aclwdntc ) + call mpas_pool_get_array(diag_physics,'aclwupb' , aclwupb ) + call mpas_pool_get_array(diag_physics,'aclwupbc' , aclwupbc ) + call mpas_pool_get_array(diag_physics,'aclwupt' , aclwupt ) + call mpas_pool_get_array(diag_physics,'aclwuptc' , aclwuptc ) + + call mpas_pool_get_array(diag_physics,'swdnb' , swdnb ) + call mpas_pool_get_array(diag_physics,'swdnbc' , swdnbc ) + call mpas_pool_get_array(diag_physics,'swdnt' , swdnt ) + call mpas_pool_get_array(diag_physics,'swdntc' , swdntc ) + call mpas_pool_get_array(diag_physics,'swupb' , swupb ) + call mpas_pool_get_array(diag_physics,'swupbc' , swupbc ) + call mpas_pool_get_array(diag_physics,'swupt' , swupt ) + call mpas_pool_get_array(diag_physics,'swuptc' , swuptc ) + call mpas_pool_get_array(diag_physics,'lwdnb' , lwdnb ) + call mpas_pool_get_array(diag_physics,'lwdnbc' , lwdnbc ) + call mpas_pool_get_array(diag_physics,'lwdnt' , lwdnt ) + call mpas_pool_get_array(diag_physics,'lwdntc' , lwdntc ) + call mpas_pool_get_array(diag_physics,'lwupb' , lwupb ) + call mpas_pool_get_array(diag_physics,'lwupbc' , lwupbc ) + call mpas_pool_get_array(diag_physics,'lwupt' , lwupt ) + call mpas_pool_get_array(diag_physics,'lwuptc' , lwuptc ) + + do iCell = 1, nCellsSolve !short-wave radiation: - diag%acswdnb %array(iCell) = diag%acswdnb %array(iCell) + diag%swdnb %array(iCell)*dt_dyn - diag%acswdnbc%array(iCell) = diag%acswdnbc%array(iCell) + diag%swdnbc%array(iCell)*dt_dyn - diag%acswdnt %array(iCell) = diag%acswdnt %array(iCell) + diag%swdnt %array(iCell)*dt_dyn - diag%acswdntc%array(iCell) = diag%acswdntc%array(iCell) + diag%swdntc%array(iCell)*dt_dyn - diag%acswupb %array(iCell) = diag%acswupb %array(iCell) + diag%swupb %array(iCell)*dt_dyn - diag%acswupbc%array(iCell) = diag%acswupbc%array(iCell) + diag%swupbc%array(iCell)*dt_dyn - diag%acswupt %array(iCell) = diag%acswupt %array(iCell) + diag%swupt %array(iCell)*dt_dyn - diag%acswuptc%array(iCell) = diag%acswuptc%array(iCell) + diag%swuptc%array(iCell)*dt_dyn + acswdnb(iCell) = acswdnb (iCell) + swdnb (iCell)*dt_dyn + acswdnbc(iCell) = acswdnbc(iCell) + swdnbc(iCell)*dt_dyn + acswdnt(iCell) = acswdnt (iCell) + swdnt (iCell)*dt_dyn + acswdntc(iCell) = acswdntc(iCell) + swdntc(iCell)*dt_dyn + acswupb(iCell) = acswupb (iCell) + swupb (iCell)*dt_dyn + acswupbc(iCell) = acswupbc(iCell) + swupbc(iCell)*dt_dyn + acswupt(iCell) = acswupt (iCell) + swupt (iCell)*dt_dyn + acswuptc(iCell) = acswuptc(iCell) + swuptc(iCell)*dt_dyn !long-wave radiation: - diag%aclwdnb %array(iCell) = diag%aclwdnb %array(iCell) + diag%lwdnb %array(iCell)*dt_dyn - diag%aclwdnbc%array(iCell) = diag%aclwdnbc%array(iCell) + diag%lwdnbc%array(iCell)*dt_dyn - diag%aclwdnt %array(iCell) = diag%aclwdnt %array(iCell) + diag%lwdnt %array(iCell)*dt_dyn - diag%aclwdntc%array(iCell) = diag%aclwdntc%array(iCell) + diag%lwdntc%array(iCell)*dt_dyn - diag%aclwupb %array(iCell) = diag%aclwupb %array(iCell) + diag%lwupb %array(iCell)*dt_dyn - diag%aclwupbc%array(iCell) = diag%aclwupbc%array(iCell) + diag%lwupbc%array(iCell)*dt_dyn - diag%aclwupt %array(iCell) = diag%aclwupt %array(iCell) + diag%lwupt %array(iCell)*dt_dyn - diag%aclwuptc%array(iCell) = diag%aclwuptc%array(iCell) + diag%lwuptc%array(iCell)*dt_dyn + aclwdnb(iCell) = aclwdnb (iCell) + lwdnb (iCell)*dt_dyn + aclwdnbc(iCell) = aclwdnbc(iCell) + lwdnbc(iCell)*dt_dyn + aclwdnt(iCell) = aclwdnt (iCell) + lwdnt (iCell)*dt_dyn + aclwdntc(iCell) = aclwdntc(iCell) + lwdntc(iCell)*dt_dyn + aclwupb(iCell) = aclwupb (iCell) + lwupb (iCell)*dt_dyn + aclwupbc(iCell) = aclwupbc(iCell) + lwupbc(iCell)*dt_dyn + aclwupt(iCell) = aclwupt (iCell) + lwupt (iCell)*dt_dyn + aclwuptc(iCell) = aclwuptc(iCell) + lwuptc(iCell)*dt_dyn enddo if(l_acradt .and. bucket_radt.gt.0._RKIND) then - do iCell = 1, mesh%nCellsSolve + do iCell = 1, nCellsSolve !short-wave radiation: - if(diag%acswdnb%array(iCell) .gt. bucket_radt) then - diag%i_acswdnb%array(iCell) = diag%i_acswdnb%array(iCell) + 1 - diag%acswdnb%array(iCell) = diag%acswdnb%array(iCell) - bucket_radt + if(acswdnb(iCell) .gt. bucket_radt) then + i_acswdnb(iCell) = i_acswdnb(iCell) + 1 + acswdnb(iCell) = acswdnb(iCell) - bucket_radt endif - if(diag%acswdnbc%array(iCell) .gt. bucket_radt) then - diag%i_acswdnbc%array(iCell) = diag%i_acswdnbc%array(iCell) + 1 - diag%acswdnbc%array(iCell) = diag%acswdnbc%array(iCell) - bucket_radt + if(acswdnbc(iCell) .gt. bucket_radt) then + i_acswdnbc(iCell) = i_acswdnbc(iCell) + 1 + acswdnbc(iCell) = acswdnbc(iCell) - bucket_radt endif - if(diag%acswdnt%array(iCell) .gt. bucket_radt) then - diag%i_acswdnt%array(iCell) = diag%i_acswdnt%array(iCell) + 1 - diag%acswdnt%array(iCell) = diag%acswdnt%array(iCell) - bucket_radt + if(acswdnt(iCell) .gt. bucket_radt) then + i_acswdnt(iCell) = i_acswdnt(iCell) + 1 + acswdnt(iCell) = acswdnt(iCell) - bucket_radt endif - if(diag%acswdntc%array(iCell) .gt. bucket_radt) then - diag%i_acswdntc%array(iCell) = diag%i_acswdntc%array(iCell) + 1 - diag%acswdntc%array(iCell) = diag%acswdntc%array(iCell) - bucket_radt + if(acswdntc(iCell) .gt. bucket_radt) then + i_acswdntc(iCell) = i_acswdntc(iCell) + 1 + acswdntc(iCell) = acswdntc(iCell) - bucket_radt endif - if(diag%acswupb%array(iCell) .gt. bucket_radt) then - diag%i_acswupb%array(iCell) = diag%i_acswupb%array(iCell) + 1 - diag%acswupb%array(iCell) = diag%acswupb%array(iCell) - bucket_radt + if(acswupb(iCell) .gt. bucket_radt) then + i_acswupb(iCell) = i_acswupb(iCell) + 1 + acswupb(iCell) = acswupb(iCell) - bucket_radt endif - if(diag%acswupbc%array(iCell) .gt. bucket_radt) then - diag%i_acswupbc%array(iCell) = diag%i_acswupbc%array(iCell) + 1 - diag%acswupbc%array(iCell) = diag%acswupbc%array(iCell) - bucket_radt + if(acswupbc(iCell) .gt. bucket_radt) then + i_acswupbc(iCell) = i_acswupbc(iCell) + 1 + acswupbc(iCell) = acswupbc(iCell) - bucket_radt endif - if(diag%acswupt%array(iCell) .gt. bucket_radt) then - diag%i_acswupt%array(iCell) = diag%i_acswupt%array(iCell) + 1 - diag%acswupt%array(iCell) = diag%acswupt%array(iCell) - bucket_radt + if(acswupt(iCell) .gt. bucket_radt) then + i_acswupt(iCell) = i_acswupt(iCell) + 1 + acswupt(iCell) = acswupt(iCell) - bucket_radt endif - if(diag%acswuptc%array(iCell) .gt. bucket_radt) then - diag%i_acswuptc%array(iCell) = diag%i_acswuptc%array(iCell) + 1 - diag%acswuptc%array(iCell) = diag%acswuptc%array(iCell) - bucket_radt + if(acswuptc(iCell) .gt. bucket_radt) then + i_acswuptc(iCell) = i_acswuptc(iCell) + 1 + acswuptc(iCell) = acswuptc(iCell) - bucket_radt endif !long-wave radiation: - if(diag%aclwdnb%array(iCell) .gt. bucket_radt) then - diag%i_aclwdnb%array(iCell) = diag%i_aclwdnb%array(iCell) + 1 - diag%aclwdnb%array(iCell) = diag%aclwdnb%array(iCell) - bucket_radt + if(aclwdnb(iCell) .gt. bucket_radt) then + i_aclwdnb(iCell) = i_aclwdnb(iCell) + 1 + aclwdnb(iCell) = aclwdnb(iCell) - bucket_radt endif - if(diag%aclwdnbc%array(iCell) .gt. bucket_radt) then - diag%i_aclwdnbc%array(iCell) = diag%i_aclwdnbc%array(iCell) + 1 - diag%aclwdnbc%array(iCell) = diag%aclwdnbc%array(iCell) - bucket_radt + if(aclwdnbc(iCell) .gt. bucket_radt) then + i_aclwdnbc(iCell) = i_aclwdnbc(iCell) + 1 + aclwdnbc(iCell) = aclwdnbc(iCell) - bucket_radt endif - if(diag%aclwdnt%array(iCell) .gt. bucket_radt) then - diag%i_aclwdnt%array(iCell) = diag%i_aclwdnt%array(iCell) + 1 - diag%aclwdnt%array(iCell) = diag%aclwdnt%array(iCell) - bucket_radt + if(aclwdnt(iCell) .gt. bucket_radt) then + i_aclwdnt(iCell) = i_aclwdnt(iCell) + 1 + aclwdnt(iCell) = aclwdnt(iCell) - bucket_radt endif - if(diag%aclwdntc%array(iCell) .gt. bucket_radt) then - diag%i_aclwdntc%array(iCell) = diag%i_aclwdntc%array(iCell) + 1 - diag%aclwdntc%array(iCell) = diag%aclwdntc%array(iCell) - bucket_radt + if(aclwdntc(iCell) .gt. bucket_radt) then + i_aclwdntc(iCell) = i_aclwdntc(iCell) + 1 + aclwdntc(iCell) = aclwdntc(iCell) - bucket_radt endif - if(diag%aclwupb%array(iCell) .gt. bucket_radt) then - diag%i_aclwupb%array(iCell) = diag%i_aclwupb%array(iCell) + 1 - diag%aclwupb%array(iCell) = diag%aclwupb%array(iCell) - bucket_radt + if(aclwupb(iCell) .gt. bucket_radt) then + i_aclwupb(iCell) = i_aclwupb(iCell) + 1 + aclwupb(iCell) = aclwupb(iCell) - bucket_radt endif - if(diag%aclwupbc%array(iCell) .gt. bucket_radt) then - diag%i_aclwupbc%array(iCell) = diag%i_aclwupbc%array(iCell) + 1 - diag%aclwupbc%array(iCell) = diag%aclwupbc%array(iCell) - bucket_radt + if(aclwupbc(iCell) .gt. bucket_radt) then + i_aclwupbc(iCell) = i_aclwupbc(iCell) + 1 + aclwupbc(iCell) = aclwupbc(iCell) - bucket_radt endif - if(diag%aclwupt%array(iCell) .gt. bucket_radt) then - diag%i_aclwupt%array(iCell) = diag%i_aclwupt%array(iCell) + 1 - diag%aclwupt%array(iCell) = diag%aclwupt%array(iCell) - bucket_radt + if(aclwupt(iCell) .gt. bucket_radt) then + i_aclwupt(iCell) = i_aclwupt(iCell) + 1 + aclwupt(iCell) = aclwupt(iCell) - bucket_radt endif - if(diag%aclwuptc%array(iCell) .gt. bucket_radt) then - diag%i_aclwuptc%array(iCell) = diag%i_aclwuptc%array(iCell) + 1 - diag%aclwuptc%array(iCell) = diag%aclwuptc%array(iCell) - bucket_radt + if(aclwuptc(iCell) .gt. bucket_radt) then + i_aclwuptc(iCell) = i_aclwuptc(iCell) + 1 + aclwuptc(iCell) = aclwuptc(iCell) - bucket_radt endif enddo diff --git a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F index fc4ca7e90b..00b46a304f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F @@ -7,8 +7,8 @@ ! !================================================================================================== module mpas_atmphys_update_surface - use mpas_configure, only: config_frac_seaice,config_sfc_albedo use mpas_dmpar + use mpas_kind_types use mpas_grid_types use mpas_atmphys_date_time @@ -40,46 +40,52 @@ module mpas_atmphys_update_surface !> add-ons and modifications to sourcecode: !> ---------------------------------------- !> * revised subroutine physics_update_sst. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-24. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-24. +!> * modified sourcecode to use pools. +!> Laura D. Fowler (laura@ucar.edu) / 2014-05-15. contains + !================================================================================================== - subroutine physics_update_surface(current_date,mesh,sfc_input) + subroutine physics_update_surface(current_date,config_sfc_albedo,mesh,sfc_input) !================================================================================================== !input variables: - type(mesh_type),intent(in) :: mesh + type(mpas_pool_type),intent(in):: mesh character(len=*),intent(in):: current_date + logical,intent(in):: config_sfc_albedo !inout variables: - type(sfc_input_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: sfc_input -!local variables: - integer:: iCell +!local pointers: +!logical,pointer:: config_sfc_albedo - integer:: nCellsSolve + integer,pointer:: nCellsSolve integer,dimension(:),pointer:: landmask real(kind=RKIND),dimension(:) ,pointer:: sfc_albbck real(kind=RKIND),dimension(:,:),pointer:: albedo12m - real(kind=RKIND),dimension(:) ,pointer:: vegfra,shdmin,shdmax real(kind=RKIND),dimension(:,:),pointer:: greenfrac +!local variables: + integer:: iCell + !-------------------------------------------------------------------------------------------------- - nCellsSolve = mesh % nCellsSolve + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) - landmask => sfc_input % landmask % array - albedo12m => sfc_input % albedo12m % array - sfc_albbck => sfc_input % sfc_albbck % array + call mpas_pool_get_array(sfc_input,'landmask' , landmask ) + call mpas_pool_get_array(sfc_input,'albedo12m' , albedo12m ) + call mpas_pool_get_array(sfc_input,'sfc_albbck', sfc_albbck) - greenfrac => sfc_input % greenfrac % array - vegfra => sfc_input % vegfra % array - shdmin => sfc_input % shdmin % array - shdmax => sfc_input % shdmax % array + call mpas_pool_get_array(sfc_input,'greenfrac' , greenfrac ) + call mpas_pool_get_array(sfc_input,'vegfra' , vegfra ) + call mpas_pool_get_array(sfc_input,'shdmin' , shdmin ) + call mpas_pool_get_array(sfc_input,'shdmax' , shdmax ) !updates the surface background albedo for the current date as a function of the monthly-mean !surface background albedo valid on the 15th day of the month, if config_sfc_albedo is true: @@ -103,26 +109,20 @@ subroutine physics_update_surface(current_date,mesh,sfc_input) end subroutine physics_update_surface !================================================================================================== - subroutine physics_update_sst(dminfo,mesh,sfc_input,diag_physics) + subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_physics) !================================================================================================== !input arguments: type(dm_info),intent(in):: dminfo - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh + logical,intent(in):: config_frac_seaice !inout arguments: - type(sfc_input_type),intent(inout) :: sfc_input - type(diag_physics_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics -!local variables: - integer:: icheck - integer:: iCell,iSoil,nCellsSolve,nSoilLevels - integer:: nb_to_land,nb_to_ocean,nb_removed - integer,dimension(:),pointer:: isltyp,ivgtyp,landmask - real(kind=RKIND):: local_min,local_max - real(kind=RKIND):: global_sst_min,global_sst_max - real(kind=RKIND):: global_xice_min,global_xice_max + integer,pointer:: nCellsSolve,nSoilLevels real(kind=RKIND),dimension(:),pointer :: sfc_albbck,sst,snow,tmn,tsk,vegfra,xice,seaice real(kind=RKIND),dimension(:),pointer :: snowc,snowh @@ -131,39 +131,50 @@ subroutine physics_update_sst(dminfo,mesh,sfc_input,diag_physics) real(kind=RKIND),dimension(:),pointer:: sfc_albedo,sfc_emiss,sfc_emibck real(kind=RKIND),dimension(:),pointer:: xicem,xland +!local variables: + integer:: icheck + integer:: iCell,iSoil + integer:: nb_to_land,nb_to_ocean,nb_removed + integer,dimension(:),pointer:: isltyp,ivgtyp,landmask + + real(kind=RKIND):: local_min,local_max + real(kind=RKIND):: global_sst_min,global_sst_max + real(kind=RKIND):: global_xice_min,global_xice_max + !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine physics_update_sst:' - write(0,*) '--- config_frac_seaice =', config_frac_seaice - write(0,*) '--- xice_threshold =', xice_threshold - write(0,*) '--- isice =', isice - write(0,*) '--- iswater=', iswater - - nCellsSolve = mesh % nCellsSolve - nSoilLevels = mesh % nSoilLevels - - isltyp => sfc_input % isltyp % array - ivgtyp => sfc_input % ivgtyp % array - landmask => sfc_input % landmask % array - vegfra => sfc_input % vegfra % array - sfc_albbck => sfc_input % sfc_albbck % array - sst => sfc_input % sst % array - tmn => sfc_input % tmn % array - tsk => sfc_input % skintemp % array - tslb => sfc_input % tslb % array - sh2o => sfc_input % sh2o % array - smois => sfc_input % smois % array - snow => sfc_input % snow % array - snowc => sfc_input % snowc % array - snowh => sfc_input % snowh % array - seaice => sfc_input % seaice % array - xice => sfc_input % xice % array - xland => sfc_input % xland % array - - sfc_albedo => diag_physics % sfc_albedo % array - sfc_emiss => diag_physics % sfc_emiss % array - sfc_emibck => diag_physics % sfc_emibck % array - xicem => diag_physics % xicem % array + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nSoilLevels',nSoilLevels) + + call mpas_pool_get_array(sfc_input,'isltyp' ,isltyp ) + call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) + call mpas_pool_get_array(sfc_input,'landmask' ,landmask ) + call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) + call mpas_pool_get_array(sfc_input,'sfc_albbck',sfc_albbck) + call mpas_pool_get_array(sfc_input,'sst' ,sst ) + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'skintemp' ,tsk ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'seaice' ,seaice ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'sfc_emibck',sfc_emibck) + call mpas_pool_get_array(diag_physics,'xicem' ,xicem ) + +! write(0,*) +! write(0,*) '--- enter subroutine physics_update_sst:' +! write(0,*) '--- config_frac_seaice =', config_frac_seaice +! write(0,*) '--- xice_threshold =', xice_threshold +! write(0,*) '--- isice =', isice +! write(0,*) '--- iswater=', iswater if(config_frac_seaice) then do iCell = 1,nCellsSolve @@ -257,10 +268,10 @@ subroutine physics_update_sst(dminfo,mesh,sfc_input,diag_physics) tslb(1,iCell) = sst(iCell) endif enddo - write(0,*) - write(0,*) '--- nb of seaice points converted to land points = ',nb_to_land - write(0,*) '--- nb of seaice points converted to ocean points = ',nb_to_ocean - write(0,*) '--- nb of seaice points less than xice threshold = ',nb_removed +! write(0,*) +! write(0,*) '--- nb of seaice points converted to land points = ',nb_to_land +! write(0,*) '--- nb of seaice points converted to ocean points = ',nb_to_ocean +! write(0,*) '--- nb of seaice points less than xice threshold = ',nb_removed !finally, update the sea-ice flag. save xice prior to next update: do iCell = 1, nCellsSolve @@ -272,38 +283,38 @@ subroutine physics_update_sst(dminfo,mesh,sfc_input,diag_physics) enddo !local and global max and min sea-surface temperatures and fractional sea-ice: - local_min = 999._RKIND - local_max = -999._RKIND - do iCell = 1,nCellsSolve - if(xland(iCell) == 2._RKIND .and. sst(iCell) <= local_min) local_min = sst(iCell) - if(xland(iCell) == 2._RKIND .and. sst(iCell) >= local_max) local_max = sst(iCell) - enddo - call mpas_dmpar_min_real(dminfo,local_min,global_sst_min) - call mpas_dmpar_max_real(dminfo,local_max,global_sst_max) - write(0,*) - write(0,*) '--- min local SST = ',local_min - write(0,*) '--- max local SST = ',local_max - write(0,*) '--- min global SST = ',global_sst_min - write(0,*) '--- max global SST = ',global_sst_max - - local_min = 999._RKIND - local_max = -999._RKIND - do iCell = 1,nCellsSolve - if(xland(iCell) == 1._RKIND .and. xice(iCell) <= local_min) local_min = xice(iCell) - if(xland(iCell) == 1._RKIND .and. xice(iCell) >= local_max) local_max = xice(iCell) - enddo - call mpas_dmpar_min_real(dminfo,local_min,global_xice_min) - call mpas_dmpar_max_real(dminfo,local_max,global_xice_max) - if(local_min .eq. 999._RKIND) local_min = 0._RKIND - if(local_max .eq. -999._RKIND) local_max = 0._RKIND - write(0,*) - write(0,*) '--- min local XICE = ',local_min - write(0,*) '--- max local XICE = ',local_max - write(0,*) '--- min global XICE = ',global_xice_min - write(0,*) '--- max global XICE = ',global_xice_max - - write(0,*) '--- end subroutine physics_update_sst' - write(0,*) +! local_min = 999._RKIND +! local_max = -999._RKIND +! do iCell = 1,nCellsSolve +! if(xland(iCell) == 2._RKIND .and. sst(iCell) <= local_min) local_min = sst(iCell) +! if(xland(iCell) == 2._RKIND .and. sst(iCell) >= local_max) local_max = sst(iCell) +! enddo +! call mpas_dmpar_min_real(dminfo,local_min,global_sst_min) +! call mpas_dmpar_max_real(dminfo,local_max,global_sst_max) +! write(0,*) +! write(0,*) '--- min local SST = ',local_min +! write(0,*) '--- max local SST = ',local_max +! write(0,*) '--- min global SST = ',global_sst_min +! write(0,*) '--- max global SST = ',global_sst_max + +! local_min = 999._RKIND +! local_max = -999._RKIND +! do iCell = 1,nCellsSolve +! if(xland(iCell) == 1._RKIND .and. xice(iCell) <= local_min) local_min = xice(iCell) +! if(xland(iCell) == 1._RKIND .and. xice(iCell) >= local_max) local_max = xice(iCell) +! enddo +! call mpas_dmpar_min_real(dminfo,local_min,global_xice_min) +! call mpas_dmpar_max_real(dminfo,local_max,global_xice_max) +! if(local_min .eq. 999._RKIND) local_min = 0._RKIND +! if(local_max .eq. -999._RKIND) local_max = 0._RKIND +! write(0,*) +! write(0,*) '--- min local XICE = ',local_min +! write(0,*) '--- max local XICE = ',local_max +! write(0,*) '--- min global XICE = ',global_xice_min +! write(0,*) '--- max global XICE = ',global_xice_max + +! write(0,*) '--- end subroutine physics_update_sst' +! write(0,*) end subroutine physics_update_sst @@ -312,12 +323,21 @@ subroutine physics_update_sstskin(dt,mesh,diag_physics,sfc_input) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: mesh real(kind=RKIND),intent(in):: dt !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(sfc_input_type),intent(inout) :: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + integer,pointer:: nCellsSolve + + real(kind=RKIND),dimension(:),pointer:: sst,tsk,xland + real(kind=RKIND),dimension(:),pointer:: glw,gsw + real(kind=RKIND),dimension(:),pointer:: hfx,qfx + real(kind=RKIND),dimension(:),pointer:: emiss,ust + real(kind=RKIND),dimension(:),pointer:: sstsk,dtc1,dtw1 !local parameters: integer, parameter:: n=1152 @@ -325,37 +345,31 @@ subroutine physics_update_sstskin(dt,mesh,diag_physics,sfc_input) real(kind=RKIND),parameter:: g=9.8,znuw=1.e-6,zkw=1.4e-7,sdate=1201.6667 !local variables: - integer:: iCell,nCellsSolve + integer:: iCell real(kind=RKIND):: lw, sw, q, qn, zeta, dep, dtw3, skinmax, skinmin real(kind=RKIND):: fs, con1, con2, con3, con4, con5, zlan, q2, ts, phi, qn1 real(kind=RKIND):: usw, qo, swo, us, tb, dtc, dtw, alw, dtwo, delt, f1 - real(kind=RKIND),dimension(:),pointer:: sst,tsk,xland - real(kind=RKIND),dimension(:),pointer:: glw,gsw - real(kind=RKIND),dimension(:),pointer:: hfx,qfx - real(kind=RKIND),dimension(:),pointer:: emiss,ust - real(kind=RKIND),dimension(:),pointer:: sstsk,dtc1,dtw1 - !-------------------------------------------------------------------------------------------------- - write(0,*) - write(0,*) '--- enter subroutine physics_update_sstskin:' +! write(0,*) +! write(0,*) '--- enter subroutine physics_update_sstskin:' - nCellsSolve = mesh % nCellsSolve + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) - tsk => sfc_input % skintemp % array - sst => sfc_input % sst % array - xland => sfc_input % xland % array + call mpas_pool_get_array(sfc_input,'skintemp',tsk ) + call mpas_pool_get_array(sfc_input,'sst' ,sst ) + call mpas_pool_get_array(sfc_input,'xland' ,xland) - sstsk => diag_physics % sstsk % array - dtc1 => diag_physics % sstsk_dtc % array - dtw1 => diag_physics % sstsk_dtw % array - emiss => diag_physics % sfc_emiss % array - glw => diag_physics % glw % array - gsw => diag_physics % gsw % array - hfx => diag_physics % hfx % array - qfx => diag_physics % qfx % array - ust => diag_physics % ust % array + call mpas_pool_get_array(diag_physics,'sstsk' ,sstsk) + call mpas_pool_get_array(diag_physics,'sstsk_dtc',dtc1 ) + call mpas_pool_get_array(diag_physics,'sstsk_dtw',dtw1 ) + call mpas_pool_get_array(diag_physics,'sfc_emiss',emiss) + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) skinmax = -9999. skinmin = 9999. @@ -447,39 +461,43 @@ subroutine physics_update_deepsoiltemp(LeapYear,dt,julian_in,mesh,sfc_input,diag !================================================================================================== !input arguments: - type(mesh_type),intent(in) :: mesh + type(mpas_pool_type),intent(in) :: mesh logical,intent(in):: LeapYear real(kind=RKIND),intent(in):: dt,julian_in !inout arguments: - type(diag_physics_type),intent(inout):: diag_physics - type(sfc_input_type),intent(inout) :: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input -!local variables: - integer:: iCell,iLag,n,nCellsSolve,nLags +!local pointers: + integer,pointer:: nCellsSolve,nLags - real(kind=RKIND),parameter:: tconst = 0.6 - real(kind=RKIND):: deltat,julian,tprior,yrday real(kind=RKIND),dimension(:),pointer:: nsteps_accum,ndays_accum real(kind=RKIND),dimension(:),pointer :: tday_accum,tmn,tsk,tyear_accum,tyear_mean real(kind=RKIND),dimension(:,:),pointer:: tlag +!local variables: + integer:: iCell,iLag,n + + real(kind=RKIND),parameter:: tconst = 0.6 + real(kind=RKIND):: deltat,julian,tprior,yrday + !-------------------------------------------------------------------------------------------------- !write(0,*) !write(0,*) '--- enter subroutine physics_update_deepsoiltemp:' - nCellsSolve = mesh % nCellsSolve - nLags = mesh % nLags + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nLags' ,nLags ) - nsteps_accum => diag_physics % nsteps_accum % array - ndays_accum => diag_physics % ndays_accum % array + call mpas_pool_get_array(diag_physics,'nsteps_accum',nsteps_accum) + call mpas_pool_get_array(diag_physics,'ndays_accum' ,ndays_accum ) + call mpas_pool_get_array(diag_physics,'tday_accum' ,tday_accum ) + call mpas_pool_get_array(diag_physics,'tyear_accum' ,tyear_accum ) + call mpas_pool_get_array(diag_physics,'tyear_mean' ,tyear_mean ) + call mpas_pool_get_array(diag_physics,'tlag' ,tlag ) - tmn => sfc_input % tmn % array - tsk => sfc_input % skintemp % array - tlag => diag_physics % tlag % array - tday_accum => diag_physics % tday_accum % array - tyear_accum => diag_physics % tyear_accum % array - tyear_mean => diag_physics % tyear_mean % array + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'skintemp',tsk ) !... defines the number of days in the year: if(LeapYear) then diff --git a/src/core_atmosphere/physics/mpas_atmphys_utilities.F b/src/core_atmosphere/physics/mpas_atmphys_utilities.F index 328650c620..5a9abd4940 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_utilities.F +++ b/src/core_atmosphere/physics/mpas_atmphys_utilities.F @@ -56,7 +56,7 @@ subroutine physics_error_fatal(str) write(0,*) write(0,*) ( '------------------------------ FATAL CALLED ------------------------------') write(0,*) trim(str) - stop ' MPAS core_physics abort' + call mpas_dmpar_global_abort('ERROR: MPAS core_physics abort') end subroutine physics_error_fatal diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 949b529694..8e32477dc9 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -7,7 +7,6 @@ ! !================================================================================================== module mpas_atmphys_vars - use mpas_kind_types implicit none @@ -26,14 +25,16 @@ module mpas_atmphys_vars !> * added the variables sf_surface_physics,alswvisdir_p,alswvisdif_p,alswnirdir_p,alswnirdif_p, !> swvisdir_p,swvisdif_p,swnirdir_p,and swnirdif_p to upgrade the RRTMG short wave radiation !> code to WRF version 3.4.1. see definition of each individual variables below. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-03-11. +!> Laura D. Fowler (laura@ucar.edu) / 2013-03-11. !> * removed call to the updated Kain-Fritsch convection scheme. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-05-29. +!> Laura D. Fowler (laura@ucar.edu) / 2013-05-29. !> * added the arrays o3clim_p for implementation of monthly-varying climatological ozone in the !> long wave and short wave RRTMG radiation codes. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-07-08. +!> Laura D. Fowler (laura@ucar.edu) / 2013-07-08. !> * corrected definition of local variable dx_p. -!> Laura D. Fowler (birch.mmm.ucar.edu) / 2013-08-23. +!> Laura D. Fowler (laura@ucar.edu) / 2013-08-23. +!> * renamed local variable conv_deep_scheme to convection_scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2014-09-18. !================================================================================================== @@ -41,7 +42,7 @@ module mpas_atmphys_vars !================================================================================================== character(len=StrKIND),public:: microp_scheme - character(len=StrKIND),public:: conv_deep_scheme + character(len=StrKIND),public:: convection_scheme character(len=StrKIND),public:: gwdo_scheme character(len=StrKIND),public:: lsm_scheme character(len=StrKIND),public:: pbl_scheme diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index 1dad7afff5..b6d15b5bb4 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -72,15 +72,19 @@ module_sf_noahdrv.o: \ module_sf_urban.o module_sf_noahlsm.o: \ - ../mpas_atmphys_constants.o + ../mpas_atmphys_constants.o \ + ../mpas_atmphys_utilities.o clean: $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../../framework -I../../../operators -I.. + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../../framework -I../../../operators -I.. -I../../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../../framework -I../../../operators -I.. + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../../framework -I../../../operators -I.. -I../../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F index 1defb3375d..1e575ee394 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F @@ -219,7 +219,7 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & #endif ! - qv2d(:,:) = 0.0 + qv2d(its:ite,:) = 0.0 do j = jts,jte if(present(mut))then ! For ARW we will replace p and p8w with dry hydrostatic pressure @@ -395,8 +395,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & !------------------------------------------------------------------- ! real,parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. - real,parameter :: rlam = 150.,prmin = 0.25,prmax = 4. -! real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4. +! real,parameter :: rlam = 150.,prmin = 0.25,prmax = 4. + real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4. real,parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 real,parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 real,parameter :: phifac = 8.,sfcfrac = 0.1 @@ -627,10 +627,10 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! !-----initialize vertical tendencies and ! - utnp(:,:) = 0. - vtnp(:,:) = 0. - ttnp(:,:) = 0. - qtnp(:,:) = 0. + utnp(its:ite,:) = 0. + vtnp(its:ite,:) = 0. + ttnp(its:ite,:) = 0. + qtnp(its:ite,:) = 0. ! do i = its,ite wspd1(i) = sqrt(ux(i,1)*ux(i,1)+vx(i,1)*vx(i,1))+1.e-9 diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F b/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F index 189a056ff9..0033c18490 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F @@ -1,3 +1,13 @@ +!================================================================================================== +!WRF version 3.6 of the Tiedtke parameterization of deep convection. Implemented in MPAS +!on 2014-06-26. +!Laura D. Fowler (birch.mmm.ucar.edu) / 2014-06-26. +!================================================================================================== +!> +!> add-ons and modifications to sourcecode: +!> ---------------------------------------- +!> + !----------------------------------------------------------------------- ! !WRF:MODEL_LAYER:PHYSICS @@ -27,9 +37,9 @@ MODULE module_cu_tiedtke #if defined(mpas) !... In MPAS, the variable RV is already defined in ./src/framework/mpas_constants.F. Here, ! we declare RV as a private variable to avoid conflicts at compilation time. -! Laura D. Fowler (birch.ucar.edu) / 2013-06-19. +! Laura D. Fowler (birch.mmm.ucar.edu) / 2014-06-26. REAL,PRIVATE :: G,CPV,RV - REAL :: API,A,EOMEGA,RD,CPD,RCPD,VTMPC1,VTMPC2, & + REAL :: API,A,EOMEGA,RD,CPD,RCPD,VTMPC1,VTMPC2, & RHOH2O,ALV,ALS,ALF,CLW,TMELT,SOLC,STBO,DAYL,YEARL, & C1ES,C2ES,C3LES,C3IES,C4LES,C4IES,C5LES,C5IES,ZRG #else @@ -38,12 +48,12 @@ MODULE module_cu_tiedtke RHOH2O,ALV,ALS,ALF,CLW,TMELT,SOLC,STBO,DAYL,YEARL, & C1ES,C2ES,C3LES,C3IES,C4LES,C4IES,C5LES,C5IES,ZRG #endif - + REAL :: ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,RHM,RHC, & CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON,CRIRH,ZBUO0, & fdbk,ZTAU - INTEGER :: nentr + INTEGER :: orgen,nturben,cutrigger REAL :: CVDIFTS, CEVAPCU1, CEVAPCU2,ZDNOPRC @@ -73,7 +83,7 @@ MODULE module_cu_tiedtke VTMPC1=RV/RD-1.0, & VTMPC2=CPV/CPD-1.0, & CVDIFTS=1.0, & - CEVAPCU1=1.93E-6*261.0*0.5/G, & ! Correction from WRFV3.4.1 sourcecode. + CEVAPCU1=1.93E-6*261.0*0.5/G, & CEVAPCU2=1.E3/(38.3*0.293) ) @@ -104,7 +114,7 @@ MODULE module_cu_tiedtke ! CMFCTOP: RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY LEVEL ! ------- ! - PARAMETER(CMFCTOP=0.26) + PARAMETER(CMFCTOP=0.30) ! ! CMFCMAX: MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC ! ------- @@ -123,19 +133,25 @@ MODULE module_cu_tiedtke ! ! CPRCON: COEFFICIENTS FOR DETERMINING CONVERSION FROM CLOUD WATER ! - PARAMETER(CPRCON = 2.0E-3/G) + PARAMETER(CPRCON = 1.1E-3/G) ! ! ZDNOPRC: The pressure depth below which no precipitation ! - PARAMETER(ZDNOPRC = 1.5E4) + PARAMETER(ZDNOPRC =1.5E4) !-------------------- - PARAMETER(nentr=1) ! Old entrainment rate parameterization ! chn1,2,4 -! PARAMETER(nentr=2) ! New entrainment rate parameterization ! chn3 + PARAMETER(orgen=1) ! Old organized entrainment rate +! PARAMETER(orgen=2) ! New organized entrainment rate + + PARAMETER(nturben=1) ! old deep turburent entrainment/detrainment rate +! PARAMETER(nturben=2) ! New deep turburent entrainment/detrainment rate + + PARAMETER(cutrigger=1) ! Old trigger function +! PARAMETER(cutrigger=2) ! New trigger function ! !-------------------- PARAMETER(RHC=0.80,RHM=1.0,ZBUO0=0.50) !-------------------- - PARAMETER(CRIRH=0.80,fdbk = 1.0,ZTAU = 3600.0) + PARAMETER(CRIRH=0.70,fdbk = 1.0,ZTAU = 1800.0) !-------------------- LOGICAL :: LMFPEN,LMFMID,LMFSCV,LMFDD,LMFDUDV PARAMETER(LMFPEN=.TRUE.,LMFMID=.TRUE.,LMFSCV=.TRUE.,LMFDD=.TRUE.,LMFDUDV=.TRUE.) @@ -145,14 +161,12 @@ MODULE module_cu_tiedtke ! CONTAINS !----------------------------------------------------------------------- - SUBROUTINE CU_TIEDTKE( & + SUBROUTINE CU_TIEDTKE( & DT,ITIMESTEP,STEPCU & - ,RAINCV,PRATEC,QFX,ZNU & + ,RAINCV,PRATEC,QFX,HFX,ZNU & ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D & ,QVFTEN,QVPBLTEN & ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG & - ,CUDT, CURR_SECS, ADAPT_STEP_FLAG & - ,CUDTACTTIME & ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte & @@ -160,7 +174,6 @@ SUBROUTINE CU_TIEDTKE( & ,RUCUTEN, RVCUTEN & ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & ) - !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -175,6 +188,8 @@ SUBROUTINE CU_TIEDTKE( & !-- P8w 3D hydrostatic pressure at full levels (Pa) !-- Pcps 3D hydrostatic pressure at half levels (Pa) !-- PI3D 3D exner function (dimensionless) +!-- QVFTEN 3D water vapor advection tendency +!-- QVPBLTEN 3D water vapor tendency due to a PBL !-- RTHCUTEN Theta tendency due to ! cumulus scheme precipitation (K/s) !-- RUCUTEN U wind tendency due to @@ -197,6 +212,7 @@ SUBROUTINE CU_TIEDTKE( & !-- dz8w dz between full levels (m) !-- QFX upward moisture flux at the surface (kg/m^2/s) !-- DT time step (s) +!-- F_QV etc flag values for tendencies, not used !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain @@ -270,30 +286,18 @@ SUBROUTINE CU_TIEDTKE( & ! to determine at run-time whether a particular tracer is in ! use or not. ! - LOGICAL, OPTIONAL :: & + LOGICAL, OPTIONAL :: & F_QV & ,F_QC & ,F_QR & ,F_QI & ,F_QS -#if defined(mpas) - REAL, INTENT(IN ):: CUDT - REAL, INTENT(IN ), OPTIONAL:: CURR_SECS - LOGICAL,INTENT(IN ), OPTIONAL:: ADAPT_STEP_FLAG - REAL, INTENT (INOUT), OPTIONAL:: CUDTACTTIME -#else -! Adaptive time-step variables - REAL, INTENT(IN ) :: CUDT - REAL, INTENT(IN ) :: CURR_SECS - LOGICAL,INTENT(IN ) , OPTIONAL :: ADAPT_STEP_FLAG - REAL, INTENT (INOUT) :: CUDTACTTIME -#endif - !--------------------------- LOCAL VARS ------------------------------ REAL, DIMENSION(ims:ime, jms:jme) :: & - QFX + QFX, & + HFX REAL :: & DELT, & @@ -302,7 +306,9 @@ SUBROUTINE CU_TIEDTKE( & REAL , DIMENSION(its:ite) :: & RCS, & RN, & - EVAP + EVAP, & + heatflux, & + rho2d INTEGER , DIMENSION(its:ite) :: SLIMSK @@ -343,8 +349,6 @@ SUBROUTINE CU_TIEDTKE( & KX - LOGICAL :: run_param , doing_adapt_dt , decided - !-------other local variables---- #if defined(mpas) !MPAS specific (Laura D. Fowler): @@ -360,70 +364,6 @@ SUBROUTINE CU_TIEDTKE( & #endif !----------------------------------------------------------------------- ! -!*** CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP -! - -! Initialization for adaptive time step. - - doing_adapt_dt = .FALSE. - IF ( PRESENT(adapt_step_flag) ) THEN - IF ( adapt_step_flag ) THEN - doing_adapt_dt = .TRUE. - IF ( cudtacttime .EQ. 0. ) THEN - cudtacttime = curr_secs + cudt*60. - END IF - END IF - END IF - -! Do we run through this scheme or not? - -! Test 1: If this is the initial model time, then yes. -! ITIMESTEP=1 -! Test 2: If the user asked for the cumulus to be run every time step, then yes. -! CUDT=0 or STEPCU=1 -! Test 3: If not adaptive dt, and this is on the requested cumulus frequency, then yes. -! MOD(ITIMESTEP,STEPCU)=0 -! Test 4: If using adaptive dt and the current time is past the last requested activate cumulus time, then yes. -! CURR_SECS >= CUDTACTTIME - -! If we do run through the scheme, we set the flag run_param to TRUE and we set the decided flag -! to TRUE. The decided flag says that one of these tests was able to say "yes", run the scheme. -! We only proceed to other tests if the previous tests all have left decided as FALSE. - -! If we set run_param to TRUE and this is adaptive time stepping, we set the time to the next -! cumulus run. - - decided = .FALSE. - run_param = .FALSE. - IF ( ( .NOT. decided ) .AND. & - ( itimestep .EQ. 1 ) ) THEN - run_param = .TRUE. - decided = .TRUE. - END IF - - IF ( ( .NOT. decided ) .AND. & - ( ( cudt .EQ. 0. ) .OR. ( stepcu .EQ. 1 ) ) ) THEN - run_param = .TRUE. - decided = .TRUE. - END IF - - IF ( ( .NOT. decided ) .AND. & - ( .NOT. doing_adapt_dt ) .AND. & - ( MOD(itimestep,stepcu) .EQ. 0 ) ) THEN - run_param = .TRUE. - decided = .TRUE. - END IF - - IF ( ( .NOT. decided ) .AND. & - ( doing_adapt_dt ) .AND. & - ( curr_secs .GE. cudtacttime ) ) THEN - run_param = .TRUE. - decided = .TRUE. - cudtacttime = curr_secs + cudt*60 - END IF - -!----------------------------------------------------------------------- - IF(run_param) THEN DO J=JTS,JTE DO I=ITS,ITE @@ -476,7 +416,6 @@ SUBROUTINE CU_TIEDTKE( & ENDDO #if defined(mpas) -!MPAS specific DO k=kts,kte zz = kte+1-k DO i=its,ite @@ -545,10 +484,12 @@ SUBROUTINE CU_TIEDTKE( & ! DO i=its,ite EVAP(i) = QFX(i,j) + heatflux(i)=HFX(i,j) + rho2d(i) = rho3d(i,1,j) ENDDO !######################################################################## - CALL TIECNV(U1,V1,T1,Q1,Q2,Q3,Q1B,Q1BL,GHT,OMG,PRSL,PRSI,EVAP, & - RN,SLIMSK,KTYPE,IM,KX,KX+1,sig1,DELT) + CALL TIECNV(U1,V1,T1,Q1,Q2,Q3,Q1B,Q1BL,GHT,OMG,PRSL,PRSI,EVAP,heatflux,rho2d, & + RN,SLIMSK,KTYPE,IM,KX,KX+1,sig1,DELT) DO I=ITS,ITE RAINCV(I,J)=RN(I)/STEPCU @@ -590,8 +531,6 @@ SUBROUTINE CU_TIEDTKE( & ENDDO - ENDIF - END SUBROUTINE CU_TIEDTKE !==================================================================== @@ -674,7 +613,7 @@ END SUBROUTINE tiedtkeinit ! subroutine TIECNV !******************************************************** SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & - pap,paph,evap,zprecc,lndj,KTYPE,lq,km,km1,sig1,dt) + pap,paph,evap,hfx,rho,zprecc,lndj,KTYPE,lq,km,km1,sig1,dt) !----------------------------------------------------------------- ! This is the interface between the meso-scale model and the mass ! flux convection module @@ -683,7 +622,7 @@ SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & real pu(lq,km),pv(lq,km),pt(lq,km),pqv(lq,km),pqvf(lq,km) real poz(lq,km),pomg(lq,km),evap(lq),zprecc(lq),pqvbl(lq,km) - + real PHHFL(lq),RHO(lq),hfx(lq) REAL PUM1(lq,km), PVM1(lq,km), & PTTE(lq,km), PQTE(lq,km), PVOM(lq,km), PVOL(lq,km), & PVERV(lq,km), PGEO(lq,km), PAP(lq,km), PAPH(lq,km1) @@ -707,8 +646,8 @@ SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & real PSHEAT,PSRAIN,PSEVAP,PSMELT,PSDISS,TT real ZTMST,ZTPP1,fliq,fice,ZTC,ZALF integer i,j,k,lq,lp,km,km1 -! real TLUCUA -! external TLUCUA +! real TLUCUA +! external TLUCUA ZTMST=dt ! Masv flux diagnostics. @@ -727,6 +666,7 @@ SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & PAPRS(j)=0.0 PAPRSM(j)=0.0 PQHFL(j)=evap(j) + PHHFL(j)=hfx(j) 8 CONTINUE ! CONVERT MODEL VARIABLES FOR MFLUX SCHEME @@ -763,7 +703,7 @@ SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & KTYPE, ICBOT, ICTOP, ZTU, ZQU, & ZLU, ZLUDE, ZMFU, ZMFD, ZRAIN, & PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, & - PCTE, sig1, lndj) + PCTE, PHHFL, RHO, sig1, lndj) ! ! TO INCLUDE THE CLOUD WATER AND CLOUD ICE DETRAINED FROM CONVECTION ! @@ -828,7 +768,7 @@ SUBROUTINE CUMASTR_NEW & KTYPE, KCBOT, KCTOP, PTU, PQU, & PLU, PLUDE, PMFU, PMFD, PRAIN, & PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT,& - PCTE, sig1, lndj) + PCTE, PHHFL, RHO, sig1, lndj) ! !***CUMASTR* MASTER ROUTINE FOR CUMULUS MASSFLUX-SCHEME ! M.TIEDTKE E.C.M.W.F. 1986/1987/1989 @@ -921,7 +861,8 @@ SUBROUTINE CUMASTR_NEW & PVOM(KLON,KLEV), PVOL(KLON,KLEV), & PQSEN(KLON,KLEV), PGEO(KLON,KLEV), & PAP(KLON,KLEV), PAPH(KLON,KLEVP1),& - PVERV(KLON,KLEV), PQHFL(KLON) + PVERV(KLON,KLEV), PQHFL(KLON), & + PHHFL(KLON), RHO(KLON) REAL PTU(KLON,KLEV), PQU(KLON,KLEV), & PLU(KLON,KLEV), PLUDE(KLON,KLEV), & PMFU(KLON,KLEV), PMFD(KLON,KLEV), & @@ -957,6 +898,7 @@ SUBROUTINE CUMASTR_NEW & KTOP0, lndj(KLON) LOGICAL LDCUM(KLON) LOGICAL LODDRAF(KLON), LLO1 + REAL CRIRH1 !------------------------------------------- ! 1. SPECIFY CONSTANTS AND PARAMETERS !------------------------------------------- @@ -1002,17 +944,33 @@ SUBROUTINE CUMASTR_NEW & *(PAPH(JL,JK+1)-PAPH(JL,JK)) 315 CONTINUE 320 CONTINUE - DO 340 JL=1,KLON + + if(cutrigger .eq. 1) then + DO JL=1,KLON KTYPE(JL)=0 - IF(ZDQCV(JL).GT.MAX(0.,1.1*PQHFL(JL)*G)) THEN + IF(ZDQCV(JL).GT.MAX(0.,1.1*PQHFL(JL)*G)) THEN KTYPE(JL)=1 - ELSE + ELSE KTYPE(JL)=2 - ENDIF + ENDIF + END DO + else if(cutrigger .eq. 2) then + CALL CUTYPE & + ( KLON, KLEV, KLEVP1, KLEVM1, & + ZTENH, ZQENH, ZQSENH, ZGEOH, PAPH, & + RHO, PHHFL, PQHFL, KTYPE, lndj ) + end if !* (C) DETERMINE MOISTURE SUPPLY FOR BOUNDARY LAYER !* AND DETERMINE CLOUD BASE MASSFLUX IGNORING !* THE EFFECTS OF DOWNDRAFTS AT THIS STAGE ! ------------------------------------------ +! do jl=1,klon +! if(ktype(jl) .ge. 1 ) then +! write(6,*)"ktype=", KTYPE(jl) +! end if +! end do + + DO 340 JL=1,KLON IKB=KCBOT(JL) ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-ZQENH(JL,IKB) ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10) @@ -1093,18 +1051,12 @@ SUBROUTINE CUMASTR_NEW & IF (LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN IF (IHMIN(JL).LT.ICTOP0(JL)) IHMIN(JL) = ICTOP0(JL) END IF - if(nentr.eq.1) then - IF(KTYPE(JL).EQ.1) THEN - ZENTR(JL)=ENTRPEN - ELSE - ZENTR(JL)=ENTRSCV - ENDIF - if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1 - else - ZDEPTH=ZRG*(ZGEOH(JL,ICTOP0(JL))-ZGEOH(JL,KCBOT(JL))) - ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH)) - if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1 - endif + IF(KTYPE(JL).EQ.1) THEN + ZENTR(JL)=ENTRPEN + ELSE + ZENTR(JL)=ENTRSCV + ENDIF + if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.05 460 CONTINUE !* (B) DO ASCENT IN 'CUASC'IN ABSENCE OF DOWNDRAFTS !---------------------------------------------------------- @@ -1126,14 +1078,9 @@ SUBROUTINE CUMASTR_NEW & ZPBMPT=PAPH(JL,KCBOT(JL))-PAPH(JL,KCTOP(JL)) IF(LDCUM(JL)) ICTOP0(JL)=KCTOP(JL) IF(LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.ZPBMPT.LT.ZDNOPRC) KTYPE(JL)=2 - IF(KTYPE(JL).EQ.2.and.nentr.eq.1) then + IF(KTYPE(JL).EQ.2) then ZENTR(JL)=ENTRSCV - if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1 - endif - if(nentr.eq.2) then - ZDEPTH=ZRG*(ZGEOH(JL,KCTOP(JL))-ZGEOH(JL,KCBOT(JL))) - ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH)) - if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1 + if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.05 endif ZRFL(JL)=ZDMFUP(JL,1) 480 CONTINUE @@ -1182,7 +1129,13 @@ SUBROUTINE CUMASTR_NEW & ! DO 511 JL=1,KLON IF(LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN - KTOP0=MAX(12,KCTOP(JL)) + do jk=KLEVM1,2,-1 + if(abs(paph(jl,jk)*0.01 - 300) .lt. 50.) then + KTOP0=MAX(jk,KCTOP(JL)) + exit + end if + end do +! KTOP0=MAX(12,KCTOP(JL)) DO JK=2,KLEV IF(JK.LE.KCBOT(JL).AND.JK.GT.KCTOP(JL)) THEN ZRO=PAPH(JL,JK)/(RD*ZTENH(JL,JK)) @@ -1201,10 +1154,20 @@ SUBROUTINE CUMASTR_NEW & ENDIF ENDDO ! - IF(ZRELH(JL).GE.CRIRH) THEN + + if(cutrigger .eq. 1 ) then + IF(lndj(JL).EQ.1) then + CRIRH1=CRIRH*0.8 + ELSE + CRIRH1=CRIRH + ENDIF + else + CRIRH1=0. + end if + + IF(ZRELH(JL).GE.CRIRH1 .AND. ZCAPE(JL) .GT. 100.) THEN IKB=KCBOT(JL) -! ZHT=MAX(0.0,(ZCAPE(JL)-300.0))/(ZTAU*ZHEAT(JL)) - ZHT=MAX(0.0,(ZCAPE(JL)-0.0))/(ZTAU*ZHEAT(JL)) + ZHT=ZCAPE(JL)/(ZTAU*ZHEAT(JL)) ZMFUB1(JL)=MAX(ZMFUB(JL)*ZHT,0.01) ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2 ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX) @@ -1614,6 +1577,345 @@ SUBROUTINE CUBASE & RETURN END SUBROUTINE CUBASE +!********************************************** +! SUBROUTINE CUTYPE +!********************************************** + SUBROUTINE CUTYPE & + ( KLON, KLEV, KLEVP1, KLEVM1,& + PTENH, PQENH, PQSENH, PGEOH, PAPH,& + RHO, HFX, QFX, KTYPE, lndj ) +! THIS ROUTINE CALCULATES CLOUD BASE and TOP +! AND RETURN CLOUD TYPES +! ZHANG & WANG IPRC 12/2010 +!***PURPOSE. +! -------- +! TO PRODUCE CLOUD TYPE for CU-PARAMETERIZATIONS +!***INTERFACE +! --------- +! THIS ROUTINE IS CALLED FROM *CUMASTR*. +! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS. +! IT RETURNS CLOUD TYPES AS FOLLOWS; +! KTYPE=1 FOR deep cumulus +! KTYPE=2 FOR shallow cumulus +!***METHOD. +! -------- +! based on a simplified updraught equation +! partial(Hup)/partial(z)=eta(H - Hup) +! eta is the entrainment rate for test parcel +! H stands for dry static energy or the total water specific humidity +! references: Christian Jakob, 2003: A new subcloud model for mass-flux convection schemes +! influence on triggering, updraft properties, and model climate, Mon.Wea.Rev. +! 131, 2765-2778 +! and +! IFS Documentation - Cy33r1 +! +!***EXTERNALS +! --------- +! *CUADJTQ* FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT +! ---------------------------------------------------------------- +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + INTEGER KLON, KLEV, KLEVP1 + INTEGER klevm1 + INTEGER JL,JK,IS,IK,ICALL,IKB,LEVELS + REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), & + PQSENH(KLON,KLEV),& + PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1) + REAL ZRELH(KLON) + REAL QFX(KLON),RHO(KLON),HFX(KLON) + REAL ZQOLD(KLON,KLEV), ZPH(KLON) + INTEGER KCTOP(KLON),KCBOT(KLON) + INTEGER KTYPE(KLON),LCLFLAG(KLON) + LOGICAL TOPFLAG(KLON),DEEPFLAG(KLON),MYFLAG(KLON) + + REAL part1(klon), part2(klon), root(klon) + REAL conw(klon),deltT(klon),deltQ(klon) + REAL eta(klon),dz(klon),coef(klon) + REAL dhen(KLON,KLEV), dh(KLON,KLEV),qh(KLON,KLEV) + REAL Tup(KLON,KLEV),Qup(KLON,KLEV),ql(KLON,KLEV) + REAL ww(KLON,KLEV),Kup(KLON,KLEV) + REAL Vtup(KLON,KLEV),Vten(KLON,KLEV),buoy(KLON,KLEV) + + INTEGER lndj(KLON) + REAL CRIRH1 +!***INPUT VARIABLES: +! PTENH [ZTENH] - Environment Temperature on half levels. (CUINI) +! PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI) +! PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX) +! PAPH - Pressure of half levels. (MSSFLX) +! RHO - Density of the lowest Model level +! QFX - net upward moisture flux at the surface (kg/m^2/s) +! HFX - net upward heat flux at the surface (W/m^2) +!***VARIABLES OUTPUT BY CUTYPE: +! KTYPE - Convection type - 1: Penetrative (CUMASTR) +! 2: Stratocumulus (CUMASTR) +! 3: Mid-level (CUASC) +!-------------------------------------------------------------- + DO JL=1,KLON + KCBOT(JL)=KLEVM1 + KCTOP(JL)=KLEVM1 + KTYPE(JL)=0 + END DO +!----------------------------------------------------------- +! let's do test,and check the shallow convection first +! the first level is JK+1 +! define deltaT and deltaQ +!----------------------------------------------------------- + DO JK=1,KLEV + DO JL=1,KLON + ZQOLD(JL,JK)=0.0 + ql(jl,jk)=0.0 ! parcel liquid water + Tup(jl,jk)=0.0 ! parcel temperature + Qup(jl,jk)=0.0 ! parcel specific humidity + dh(jl,jk)=0.0 ! parcel dry static energy + qh(jl,jk)=0.0 ! parcel total water specific humidity + ww(jl,jk)=0.0 ! parcel vertical speed (m/s) + dhen(jl,jk)=0.0 ! environment dry static energy + Kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + Vtup(jl,jk)=0.0 ! parcel virtual temperature considering water-loading + Vten(jl,jk)=0.0 ! environment virtual temperature + buoy(jl,jk)=0.0 ! parcel buoyancy + END DO + END DO + + do jl=1,klon + lclflag(jl) = 0 ! flag for the condensation level + conw(jl) = 0.0 ! convective-scale velocity,also used for the vertical speed at the first level + myflag(jl) = .true. ! just as input for cuadjqt subroutine + topflag(jl) = .false.! flag for whether the cloud top is found + end do + +! check the levels from lowest level to second top level + do JK=KLEVM1,2,-1 + DO JL=1,KLON + ZPH(JL)=PAPH(JL,JK) + END DO + +! define the variables at the first level + if(jk .eq. KLEVM1) then + do jl=1,klon + part1(jl) = 1.5*0.4*pgeoh(jl,jk+1)/(rho(jl)*ptenh(jl,jk+1)) + part2(jl) = hfx(jl)/cpd+0.61*ptenh(jl,jk+1)*qfx(jl) + root(jl) = 0.001-part1(jl)*part2(jl) + if(root(jl) .gt. 0) then + conw(jl) = 1.2*(root(jl))**(1.0/3.0) + else + conw(jl) = -1.2*(-root(jl))**(1.0/3.0) + end if + deltT(jl) = -1.5*hfx(jl)/(rho(jl)*cpd*conw(jl)) + deltQ(jl) = -1.5*qfx(jl)/(rho(jl)*conw(jl)) + + Tup(jl,jk+1) = ptenh(jl,jk+1) + deltT(jl) + Qup(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl) + ql(jl,jk+1) = 0. + dh(jl,jk+1) = pgeoh(jl,jk+1) + Tup(jl,jk+1)*cpd + qh(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl) + ql(jl,jk+1) + ww(jl,jk+1) = conw(jl) + end do + end if + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(.not. topflag(jl)) then + eta(jl) = 0.5*(0.55/(pgeoh(jl,jk)*zrg)+1.0e-3) + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*dhen(jl,jk) + dh(jl,jk+1))/(1+coef(jl)) + qh(jl,jk) = (coef(jl)*pqenh(jl,jk)+ qh(jl,jk+1))/(1+coef(jl)) + Tup(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*RCPD + Qup(jl,jk) = qh(jl,jk) - ql(jl,jk+1) + zqold(jl,jk) = Qup(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call CUADJTQ(klon,klev,ik,zph,Tup,Qup,myflag,icall) + do jl=1,klon + if( .not. topflag(jl) .and. zqold(jl,jk) .ne. Qup(jl,jk) ) then + lclflag(jl) = lclflag(jl) + 1 + ql(jl,jk) = ql(jl,jk+1) + zqold(jl,jk) - Qup(jl,jk) + dh(jl,jk) = pgeoh(jl,jk) + cpd*Tup(jl,jk) + end if + end do + +! compute the updraft speed + do jl=1,klon + if(.not. topflag(jl))then + Kup(jl,jk+1) = 0.5*ww(jl,jk+1)**2 + Vtup(jl,jk) = Tup(jl,jk)*(1.+VTMPC1*Qup(jl,jk)-ql(jl,jk)) + Vten(jl,jk) = ptenh(jl,jk)*(1.+VTMPC1*pqenh(jl,jk)) + buoy(jl,jk) = (Vtup(jl,jk) - Vten(jl,jk))/Vten(jl,jk)*g + Kup(jl,jk) = (Kup(jl,jk+1) + 0.333*dz(jl)*buoy(jl,jk))/ & + (1+2*2*eta(jl)*dz(jl)) + if(Kup(jl,jk) .gt. 0 ) then + ww(jl,jk) = sqrt(2*Kup(jl,jk)) + if(lclflag(jl) .eq. 1 ) kcbot(jl) = jk + if(jk .eq. 2) then + kctop(jl) = jk + topflag(jl)= .true. + end if + else + ww(jl,jk) = 0 + kctop(jl) = jk + 1 + topflag(jl) = .true. + end if + end if + end do + end do ! end all the levels + + do jl=1,klon + if(paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .lt. ZDNOPRC .and. & + paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .gt. 0 & + .and. lclflag(jl) .gt. 0) then + ktype(jl) = 2 + end if + end do + +!----------------------------------------------------------- +! Next, let's check the deep convection +! the first level is JK +! define deltaT and deltaQ +!---------------------------------------------------------- +! we check the parcel starting level by level (from the second lowest level to the next 12th level, +! usually, the 12th level around 700 hPa for common eta levels) + do levels=KLEVM1-1,KLEVM1-12,-1 + DO JK=1,KLEV + DO JL=1,KLON + ZQOLD(JL,JK)=0.0 + ql(jl,jk)=0.0 ! parcel liquid water + Tup(jl,jk)=0.0 ! parcel temperature + Qup(jl,jk)=0.0 ! parcel specific humidity + dh(jl,jk)=0.0 ! parcel dry static energy + qh(jl,jk)=0.0 ! parcel total water specific humidity + ww(jl,jk)=0.0 ! parcel vertical speed (m/s) + dhen(jl,jk)=0.0 ! environment dry static energy + Kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + Vtup(jl,jk)=0.0 ! parcel virtual temperature considering water-loading + Vten(jl,jk)=0.0 ! environment virtual temperature + buoy(jl,jk)=0.0 ! parcel buoyancy + END DO + END DO + + do jl=1,klon + lclflag(jl) = 0 ! flag for the condensation level + kctop(jl) = levels + kcbot(jl) = levels + myflag(jl) = .true. ! just as input for cuadjqt subroutine + topflag(jl) = .false.! flag for whether the cloud top is found + end do + +! check the levels from lowest level to second top level + do JK=levels,2,-1 + DO JL=1,KLON + ZPH(JL)=PAPH(JL,JK) + END DO + +! define the variables at the first level + if(jk .eq. levels) then + do jl=1,klon + deltT(jl) = 0.2 + deltQ(jl) = 1.0e-4 + + if(paph(jl,KLEVM1-1)-paph(jl,jk) .le. 6.e3) then + ql(jl,jk+1) = 0. + Tup(jl,jk+1) = 0.25*(ptenh(jl,jk+1)+ptenh(jl,jk)+ & + ptenh(jl,jk-1)+ptenh(jl,jk-2)) + & + deltT(jl) + dh(jl,jk+1) = 0.25*(pgeoh(jl,jk+1)+pgeoh(jl,jk)+ & + pgeoh(jl,jk-1)+pgeoh(jl,jk-2)) + & + Tup(jl,jk+1)*cpd + qh(jl,jk+1) = 0.25*(pqenh(jl,jk+1)+pqenh(jl,jk)+ & + pqenh(jl,jk-1)+pqenh(jl,jk-2))+ & + deltQ(jl) + ql(jl,jk+1) + Qup(jl,jk+1) = qh(jl,jk+1) - ql(jl,jk+1) + else + ql(jl,jk+1) = 0. + Tup(jl,jk+1) = ptenh(jl,jk+1) + deltT(jl) + dh(jl,jk+1) = pgeoh(jl,jk+1) + Tup(jl,jk+1)*cpd + qh(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl) + Qup(jl,jk+1) = qh(jl,jk+1) - ql(jl,jk+1) + end if + ww(jl,jk+1) = 1.0 + + end do + end if + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(.not. topflag(jl)) then + eta(jl) = 1.1e-4 + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*dhen(jl,jk) + dh(jl,jk+1))/(1+coef(jl)) + qh(jl,jk) = (coef(jl)*pqenh(jl,jk)+ qh(jl,jk+1))/(1+coef(jl)) + Tup(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*RCPD + Qup(jl,jk) = qh(jl,jk) - ql(jl,jk+1) + zqold(jl,jk) = Qup(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call CUADJTQ(klon,klev,ik,zph,Tup,Qup,myflag,icall) + do jl=1,klon + if( .not. topflag(jl) .and. zqold(jl,jk) .ne. Qup(jl,jk) ) then + lclflag(jl) = lclflag(jl) + 1 + ql(jl,jk) = ql(jl,jk+1) + zqold(jl,jk) - Qup(jl,jk) + dh(jl,jk) = pgeoh(jl,jk) + cpd*Tup(jl,jk) + end if + end do + +! compute the updraft speed + do jl=1,klon + if(.not. topflag(jl))then + Kup(jl,jk+1) = 0.5*ww(jl,jk+1)**2 + Vtup(jl,jk) = Tup(jl,jk)*(1.+VTMPC1*Qup(jl,jk)-ql(jl,jk)) + Vten(jl,jk) = ptenh(jl,jk)*(1.+VTMPC1*pqenh(jl,jk)) + buoy(jl,jk) = (Vtup(jl,jk) - Vten(jl,jk))/Vten(jl,jk)*g + Kup(jl,jk) = (Kup(jl,jk+1) + 0.333*dz(jl)*buoy(jl,jk))/ & + (1+2*2*eta(jl)*dz(jl)) + if(Kup(jl,jk) .gt. 0 ) then + ww(jl,jk) = sqrt(2*Kup(jl,jk)) + if(lclflag(jl) .eq. 1 ) kcbot(jl) = jk + if(jk .eq. 2) then + kctop(jl) = jk + topflag(jl)= .true. + end if + else + ww(jl,jk) = 0 + kctop(jl) = jk + 1 + topflag(jl) = .true. + end if + end if + end do + end do ! end all the levels + + do jl = 1, klon + if(paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .gt. ZDNOPRC .and. & + lclflag(jl) .gt. 0 ) then + ZRELH(JL) = 0. + do jk=kcbot(jl),kctop(jl),-1 + ZRELH(JL)=ZRELH(JL)+ PQENH(JL,JK)/PQSENH(JL,JK) + end do + ZRELH(JL) = ZRELH(JL)/(kcbot(jl)-kctop(jl)+1) + + if(lndj(JL) .eq. 1) then + CRIRH1 = CRIRH*0.8 + else + CRIRH1 = CRIRH + end if + if(ZRELH(JL) .ge. CRIRH1) ktype(jl) = 1 + end if + end do + + end do ! end all cycles + + END SUBROUTINE CUTYPE + ! !********************************************** ! SUBROUTINE CUASC_NEW @@ -1692,7 +1994,7 @@ SUBROUTINE CUASC_NEW & ! PMFUQ [ZMFUQ] - Updraft Flux of Specific Humidity. ! PMFUL [ZMFUL] - Updraft Flux of Cloud Liquid Water. ! PLUDE - Liquid Water Returned to Environment by Detrainment. -! PDMFUP [ZMFUP] - +! PDMFUP [ZMFUP] - FLUX DIFFERENCE OF PRECIP. IN UPDRAFTS ! KCBOT - Cloud Base Level. (CUBASE) ! KCTOP - ! KCTOP0 [ICTOP0] - Estimate of Cloud Top. (CUMASTR) @@ -1733,7 +2035,12 @@ SUBROUTINE CUASC_NEW & KLAB(KLON,KLEV), KCBOT(KLON), & KCTOP(KLON), KCTOP0(KLON), & KHMIN(KLON) - LOGICAL LDCUM(KLON), LOFLAG(KLON) + LOGICAL LDCUM(KLON), LOFLAG(KLON) + integer leveltop,levelbot + real tt(klon),ttb(klon) + real zqsat(klon), zqsatb(klon) + real fscale(klon) + !-------------------------------- !* 1. SPECIFY PARAMETERS !-------------------------------- @@ -1787,8 +2094,10 @@ SUBROUTINE CUASC_NEW & DO 322 JL=1,KLON LDCUM(JL)=.FALSE. IF (KTYPE(JL).EQ.1) THEN - IKB = KCBOT(JL) - ZBUOY(JL)=G*((PTU(JL,IKB)-PTENH(JL,IKB))/PTENH(JL,IKB)+ & + IKB = KCBOT(JL) + if(orgen .eq. 1 ) then +! old scheme + ZBUOY(JL)=G*((PTU(JL,IKB)-PTENH(JL,IKB))/PTENH(JL,IKB)+ & 0.608*(PQU(JL,IKB)-PQENH(JL,IKB))) IF (ZBUOY(JL).GT.0.) THEN ZDZ = (PGEO(JL,IKB-1)-PGEO(JL,IKB))*ZRG @@ -1799,6 +2108,21 @@ SUBROUTINE CUASC_NEW & ZOENTR(JL,IKB-1) = MIN(ZOENTR(JL,IKB-1),1.E-3) ZOENTR(JL,IKB-1) = MAX(ZOENTR(JL,IKB-1),0.) END IF +! New scheme +! Let's define the fscale + else if(orgen .eq. 2 ) then + tt(jl) = ptenh(jl,ikb-1) + zqsat(jl) = TLUCUA(tt(jl))/paph(jl,ikb-1) + zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl)) + ttb(jl) = ptenh(jl,ikb) + zqsatb(jl) = TLUCUA(ttb(jl))/paph(jl,ikb) + zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl)) + fscale(jl) = (zqsat(jl)/zqsatb(jl))**3 +! end of defining the fscale + zoentr(jl,ikb-1) = 1.E-3*(1.3-PQEN(jl,ikb-1)/PQSEN(jl,ikb-1))*fscale(jl) + zoentr(jl,ikb-1) = MIN(zoentr(jl,ikb-1),1.E-3) + zoentr(jl,ikb-1) = MAX(zoentr(jl,ikb-1),0.) + end if END IF 322 CONTINUE ! @@ -1809,12 +2133,23 @@ SUBROUTINE CUASC_NEW & ! THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY !----------------------------------------------------------------- 400 CONTINUE + +! let's define the levels in which the middle level convection could be activated + do jk=KLEVM1,2,-1 + if(abs(paph(1,jk)*0.01 - 250) .lt. 50.) then + leveltop = jk + exit + end if + end do + leveltop = min(KLEV-15,leveltop) + levelbot = KLEVM1 - 4 + DO 480 JK=KLEVM1,2,-1 ! SPECIFY CLOUD BASE VALUES FOR MIDLEVEL CONVECTION ! IN *CUBASMC* IN CASE THERE IS NOT ALREADY CONVECTION ! --------------------------------------------------------------------- IK=JK - IF(LMFMID.AND.IK.LT.KLEVM1.AND.IK.GT.KLEV-13) THEN + IF(LMFMID.AND.IK.LT.levelbot.AND.IK.GT.leveltop) THEN CALL CUBASMC & (KLON, KLEV, KLEVM1, IK, PTEN, & PQEN, PQSEN, PUEN, PVEN, PVERV, & @@ -2003,6 +2338,8 @@ SUBROUTINE CUASC_NEW & ! DO 470 jl = 1, klon IF (loflag(jl).AND.ktype(jl).EQ.1) THEN +! old scheme + if(orgen .eq. 1 ) then zbuoyz=g*((ptu(jl,jk)-ptenh(jl,jk))/ptenh(jl,jk)+ & 0.608*(pqu(jl,jk)-pqenh(jl,jk))-plu(jl,jk)) zbuoyz = MAX(zbuoyz,0.0) @@ -2013,6 +2350,21 @@ SUBROUTINE CUASC_NEW & zoentr(jl,jk-1) = zbuoyz*0.5/(1.+zbuoy(jl))+zdrodz zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3) zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.) + else if(orgen .eq. 2 ) then +! Let's define the fscale + tt(jl) = ptenh(jl,jk-1) + zqsat(jl) = TLUCUA(tt(jl))/paph(jl,jk-1) + zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl)) + ttb(jl) = ptenh(jl,kcbot(jl)) + zqsatb(jl) = TLUCUA(ttb(jl))/paph(jl,kcbot(jl)) + zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl)) + fscale(jl) = (zqsat(jl)/zqsatb(jl))**3 +! end of defining the fscale + zoentr(jl,jk-1) = 1.E-3*(1.3-PQEN(jl,jk-1)/PQSEN(jl,jk-1))*fscale(jl) + zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3) + zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.) +! write(6,*) "zoentr=",zoentr(jl,jk-1) + end if END IF 470 CONTINUE ! @@ -2815,7 +3167,7 @@ SUBROUTINE CUBASMC & 100 CONTINUE DO 150 JL=1,KLON IF( .NOT. LDCUM(JL).AND.KLAB(JL,KK+1).EQ.0.0.AND. & - PQEN(JL,KK).GT.0.90*PQSEN(JL,KK)) THEN + PQEN(JL,KK).GT.0.80*PQSEN(JL,KK)) THEN PTU(JL,KK+1)=(CPD*PTEN(JL,KK)+PGEO(JL,KK)-PGEOH(JL,KK+1)) & *RCPD PQU(JL,KK+1)=PQEN(JL,KK) @@ -3048,6 +3400,10 @@ SUBROUTINE CUENTR_NEW & KCBOT(KLON), KCTOP0(KLON), & KHMIN(KLON) LOGICAL LDCUM(KLON),LLO1,LLO2 + + real tt(klon),ttb(klon) + real zqsat(klon), zqsatb(klon) + real fscale(klon) !--------------------------------------------------------- !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES !--------------------------------------------------------- @@ -3059,28 +3415,45 @@ SUBROUTINE CUENTR_NEW & zpbase(jl) = paph(jl,kcbot(jl)) zrrho = (rd*ptenh(jl,kk+1))/paph(jl,kk+1) zdprho = (paph(jl,kk+1)-paph(jl,kk))*zrg +! old or new choice zpmid = 0.5*(zpbase(jl)+paph(jl,kctop0(jl))) zentr = pentr(jl)*pmfu(jl,kk+1)*zdprho*zrrho llo1 = kk.LT.kcbot(jl).AND.ldcum(jl) +! old or new choice if(llo1) then - zdmfde(jl) = zentr + if(nturben.eq.1) zdmfde(jl) = zentr + if(nturben.eq.2) zdmfde(jl) = zentr*1.2 else - zdmfde(jl) = 0.0 + zdmfde(jl) = 0.0 endif +! old or new choice + if(nturben .eq. 1) then + fscale(jl) = 1.0 + elseif (nturben .eq. 2) then +! defining the facale + tt(jl) = ptenh(jl,kk+1) + zqsat(jl) = TLUCUA(tt(jl))/paph(jl,kk+1) + zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl)) + ttb(jl) = ptenh(jl,kcbot(jl)) + zqsatb(jl) = TLUCUA(ttb(jl))/zpbase(jl) + zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl)) + fscale(jl) = 4.0*(zqsat(jl)/zqsatb(jl))**2 + end if +! end of defining the fscale llo2 = llo1.AND.ktype(jl).EQ.2.AND.((zpbase(jl)-paph(jl,kk)) & .LT.ZDNOPRC.OR.paph(jl,kk).GT.zpmid) if(llo2) then - zdmfen(jl) = zentr + zdmfen(jl) = zentr*fscale(jl) else zdmfen(jl) = 0.0 endif iklwmin = MAX(klwmin(jl),kctop0(jl)+2) llo2 = llo1.AND.ktype(jl).EQ.3.AND.(kk.GE.iklwmin.OR.pap(jl,kk) & .GT.zpmid) - IF (llo2) zdmfen(jl) = zentr + IF (llo2) zdmfen(jl) = zentr*fscale(jl) llo2 = llo1.AND.ktype(jl).EQ.1 ! Turbulent entrainment - IF (llo2) zdmfen(jl) = zentr + IF (llo2) zdmfen(jl) = zentr*fscale(jl) ! Organized detrainment, detrainment starts at khmin ikb = kcbot(jl) zodetr(jl,kk) = 0. @@ -3097,10 +3470,9 @@ SUBROUTINE CUENTR_NEW & END IF END IF ENDDO -! +! RETURN END SUBROUTINE CUENTR_NEW -! !********************************************************** ! FUNCTION SSUM, TLUCUA, TLUCUB, TLUCUC @@ -3132,7 +3504,7 @@ REAL FUNCTION TLUCUA(TT) ! Set up lookup tables for cloud ascent calculations. ! IMPLICIT NONE - REAL ZCVM3,ZCVM4,TT !,TLUCUA + REAL ZCVM3,ZCVM4,TT ! IF(TT-TMELT.GT.0.) THEN ZCVM3=C3LES @@ -3151,7 +3523,7 @@ REAL FUNCTION TLUCUB(TT) ! Set up lookup tables for cloud ascent calculations. ! IMPLICIT NONE - REAL Z5ALVCP,Z5ALSCP,ZCVM4,ZCVM5,TT !,TLUCUB + REAL Z5ALVCP,Z5ALSCP,ZCVM4,ZCVM5,TT ! Z5ALVCP=C5LES*ALV/CPD Z5ALSCP=C5IES*ALS/CPD @@ -3172,7 +3544,7 @@ REAL FUNCTION TLUCUC(TT) ! Set up lookup tables for cloud ascent calculations. ! IMPLICIT NONE - REAL ZALVDCP,ZALSDCP,TT,ZLDCP !,TLUCUC + REAL ZALVDCP,ZALSDCP,TT,ZLDCP ! ZALVDCP=ALV/CPD ZALSDCP=ALS/CPD diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F b/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F index 4b6f5ea47d..37fd487e07 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F @@ -2632,6 +2632,19 @@ subroutine get_rf_scales(scales) integer i ! loop index + write(0,*) + write(0,*) '--- enter subroutine get_rf_scales:' + write(0,*) '--- naer_all = ', naer_all + write(0,*) '--- idxBG = ', idxBG + write(0,*) '--- idxSUL = ', idxSUL + write(0,*) '--- idxSSLT = ', idxSSLT + write(0,*) '--- idxCARBONfirst = ', idxCARBONfirst + write(0,*) '--- numCARBON = ', numCARBON + write(0,*) '--- idxDUSTfirst = ', idxDUSTfirst + write(0,*) '--- numDUST = ', numDUST + write(0,*) '--- idxVOLC = ', idxVOLC + stop + scales(idxBG) = bgscl_rf scales(idxSUL) = sulscl_rf scales(idxSSLT) = ssltscl_rf diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F index d56523cbd0..7365e20d3d 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F @@ -11725,10 +11725,6 @@ SUBROUTINE RRTMG_LWRAD( & ENDIF #endif - write(0,*) - write(0,*) '--- enter subroutine RRTMG_LWRAD:' - write(0,*) '--- o3input = ',o3input - !-----CALCULATE LONG WAVE RADIATION ! ! All fields are ordered vertically from bottom to top diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F index a044b93d11..aab9cafab3 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F @@ -5926,7 +5926,6 @@ end subroutine cmbgb29 !*********************************************************************** subroutine swcldpr -!*********************************************************************** ! Purpose: Define cloud extinction coefficient, single scattering albedo ! and asymmetry parameter data. @@ -5978,14 +5977,17 @@ subroutine swcldpr ! ice particles larger than 140.0 microns. ! LIQFLAG = 1: The water droplet effective radius (microns) is input ! and the optical depths due to water clouds are computed -! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). +! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993) with +! modified coefficients derived from Mie scattering calculations. ! The values for absorption coefficients appropriate for -! the spectral bands in RRTM have been obtained for a +! the spectral bands in RRTM/RRTMG have been obtained for a ! range of effective radii by an averaging procedure ! based on the work of J. Pinto (private communication). ! Linear interpolation is used to get the absorption ! coefficients for the input effective radius. ! +!..Updated tables suggested by Peter Blossey (Univ. Washington) that came from RRTM v3.9 from AER, Inc. +! ! ------------------------------------------------------------------ ! Everything below is for INFLAG = 2. @@ -6004,557 +6006,597 @@ subroutine swcldpr fbari(:) = (/ & & 5.851e-04_rb,5.665e-04_rb,7.204e-04_rb,7.463e-04_rb,1.076e-04_rb /) -! Extinction coefficient +! LIQFLAG==1 extinction coefficients, single scattering albedos, and asymmetry parameters +! Derived from on Mie scattering computations; based on Hu & Stamnes coefficients +! BAND 16 extliq1(:, 16) = (/ & - & 8.981463e-01_rb,6.317895e-01_rb,4.557508e-01_rb,3.481624e-01_rb,2.797950e-01_rb,& - & 2.342753e-01_rb,2.026934e-01_rb,1.800102e-01_rb,1.632408e-01_rb,1.505384e-01_rb,& - & 1.354524e-01_rb,1.246520e-01_rb,1.154342e-01_rb,1.074756e-01_rb,1.005353e-01_rb,& - & 9.442987e-02_rb,8.901760e-02_rb,8.418693e-02_rb,7.984904e-02_rb,7.593229e-02_rb,& - & 7.237827e-02_rb,6.913887e-02_rb,6.617415e-02_rb,6.345061e-02_rb,6.094001e-02_rb,& - & 5.861834e-02_rb,5.646506e-02_rb,5.446250e-02_rb,5.249596e-02_rb,5.081114e-02_rb,& - & 4.922243e-02_rb,4.772189e-02_rb,4.630243e-02_rb,4.495766e-02_rb,4.368189e-02_rb,& - & 4.246995e-02_rb,4.131720e-02_rb,4.021941e-02_rb,3.917276e-02_rb,3.817376e-02_rb,& - & 3.721926e-02_rb,3.630635e-02_rb,3.543237e-02_rb,3.459491e-02_rb,3.379171e-02_rb,& - & 3.302073e-02_rb,3.228007e-02_rb,3.156798e-02_rb,3.088284e-02_rb,3.022315e-02_rb,& - & 2.958753e-02_rb,2.897468e-02_rb,2.838340e-02_rb,2.781258e-02_rb,2.726117e-02_rb,& - & 2.672821e-02_rb,2.621278e-02_rb,2.5714e-02_rb /) + & 9.004493E-01_rb,6.366723E-01_rb,4.542354E-01_rb,3.468253E-01_rb,2.816431E-01_rb,& + & 2.383415E-01_rb,2.070854E-01_rb,1.831854E-01_rb,1.642115E-01_rb,1.487539E-01_rb,& + & 1.359169E-01_rb,1.250900E-01_rb,1.158354E-01_rb,1.078400E-01_rb,1.008646E-01_rb,& + & 9.472307E-02_rb,8.928000E-02_rb,8.442308E-02_rb,8.005924E-02_rb,7.612231E-02_rb,& + & 7.255153E-02_rb,6.929539E-02_rb,6.631769E-02_rb,6.358153E-02_rb,6.106231E-02_rb,& + & 5.873077E-02_rb,5.656924E-02_rb,5.455769E-02_rb,5.267846E-02_rb,5.091923E-02_rb,& + & 4.926692E-02_rb,4.771154E-02_rb,4.623923E-02_rb,4.484385E-02_rb,4.351539E-02_rb,& + & 4.224615E-02_rb,4.103385E-02_rb,3.986538E-02_rb,3.874077E-02_rb,3.765462E-02_rb,& + & 3.660077E-02_rb,3.557384E-02_rb,3.457615E-02_rb,3.360308E-02_rb,3.265000E-02_rb,& + & 3.171770E-02_rb,3.080538E-02_rb,2.990846E-02_rb,2.903000E-02_rb,2.816461E-02_rb,& + & 2.731539E-02_rb,2.648231E-02_rb,2.566308E-02_rb,2.485923E-02_rb,2.407000E-02_rb,& + & 2.329615E-02_rb,2.253769E-02_rb,2.179615E-02_rb /) +! BAND 17 extliq1(:, 17) = (/ & - & 8.293797e-01_rb,6.048371e-01_rb,4.465706e-01_rb,3.460387e-01_rb,2.800064e-01_rb,& - & 2.346584e-01_rb,2.022399e-01_rb,1.782626e-01_rb,1.600153e-01_rb,1.457903e-01_rb,& - & 1.334061e-01_rb,1.228548e-01_rb,1.138396e-01_rb,1.060486e-01_rb,9.924856e-02_rb,& - & 9.326208e-02_rb,8.795158e-02_rb,8.320883e-02_rb,7.894750e-02_rb,7.509792e-02_rb,& - & 7.160323e-02_rb,6.841653e-02_rb,6.549889e-02_rb,6.281763e-02_rb,6.034516e-02_rb,& - & 5.805802e-02_rb,5.593615e-02_rb,5.396226e-02_rb,5.202302e-02_rb,5.036246e-02_rb,& - & 4.879606e-02_rb,4.731610e-02_rb,4.591565e-02_rb,4.458852e-02_rb,4.332912e-02_rb,& - & 4.213243e-02_rb,4.099390e-02_rb,3.990941e-02_rb,3.887522e-02_rb,3.788792e-02_rb,& - & 3.694440e-02_rb,3.604183e-02_rb,3.517760e-02_rb,3.434934e-02_rb,3.355485e-02_rb,& - & 3.279211e-02_rb,3.205925e-02_rb,3.135458e-02_rb,3.067648e-02_rb,3.002349e-02_rb,& - & 2.939425e-02_rb,2.878748e-02_rb,2.820200e-02_rb,2.763673e-02_rb,2.709062e-02_rb,& - & 2.656272e-02_rb,2.605214e-02_rb,2.5558e-02_rb /) + & 6.741200e-01_rb,5.390739e-01_rb,4.198767e-01_rb,3.332553e-01_rb,2.735633e-01_rb,& + & 2.317727e-01_rb,2.012760e-01_rb,1.780400e-01_rb,1.596927e-01_rb,1.447980e-01_rb,& + & 1.324480e-01_rb,1.220347e-01_rb,1.131327e-01_rb,1.054313e-01_rb,9.870534e-02_rb,& + & 9.278200e-02_rb,8.752599e-02_rb,8.282933e-02_rb,7.860600e-02_rb,7.479133e-02_rb,& + & 7.132800e-02_rb,6.816733e-02_rb,6.527401e-02_rb,6.261266e-02_rb,6.015934e-02_rb,& + & 5.788867e-02_rb,5.578134e-02_rb,5.381667e-02_rb,5.198133e-02_rb,5.026067e-02_rb,& + & 4.864466e-02_rb,4.712267e-02_rb,4.568066e-02_rb,4.431200e-02_rb,4.300867e-02_rb,& + & 4.176600e-02_rb,4.057400e-02_rb,3.942534e-02_rb,3.832066e-02_rb,3.725068e-02_rb,& + & 3.621400e-02_rb,3.520533e-02_rb,3.422333e-02_rb,3.326400e-02_rb,3.232467e-02_rb,& + & 3.140535e-02_rb,3.050400e-02_rb,2.962000e-02_rb,2.875267e-02_rb,2.789800e-02_rb,& + & 2.705934e-02_rb,2.623667e-02_rb,2.542667e-02_rb,2.463200e-02_rb,2.385267e-02_rb,& + & 2.308667e-02_rb,2.233667e-02_rb,2.160067e-02_rb /) +! BAND 18 extliq1(:, 18) = (/ & - & 9.193685e-01_rb,6.128292e-01_rb,4.344150e-01_rb,3.303048e-01_rb,2.659500e-01_rb,& - & 2.239727e-01_rb,1.953457e-01_rb,1.751012e-01_rb,1.603515e-01_rb,1.493360e-01_rb,& - & 1.323791e-01_rb,1.219335e-01_rb,1.130076e-01_rb,1.052926e-01_rb,9.855839e-02_rb,& - & 9.262925e-02_rb,8.736918e-02_rb,8.267112e-02_rb,7.844965e-02_rb,7.463585e-02_rb,& - & 7.117343e-02_rb,6.801601e-02_rb,6.512503e-02_rb,6.246815e-02_rb,6.001806e-02_rb,& - & 5.775154e-02_rb,5.564872e-02_rb,5.369250e-02_rb,5.176284e-02_rb,5.011536e-02_rb,& - & 4.856099e-02_rb,4.709211e-02_rb,4.570193e-02_rb,4.438430e-02_rb,4.313375e-02_rb,& - & 4.194529e-02_rb,4.081443e-02_rb,3.973712e-02_rb,3.870966e-02_rb,3.772866e-02_rb,& - & 3.679108e-02_rb,3.589409e-02_rb,3.503514e-02_rb,3.421185e-02_rb,3.342206e-02_rb,& - & 3.266377e-02_rb,3.193513e-02_rb,3.123447e-02_rb,3.056018e-02_rb,2.991081e-02_rb,& - & 2.928502e-02_rb,2.868154e-02_rb,2.809920e-02_rb,2.753692e-02_rb,2.699367e-02_rb,& - & 2.646852e-02_rb,2.596057e-02_rb,2.5469e-02_rb /) + & 9.250861e-01_rb,6.245692e-01_rb,4.347038e-01_rb,3.320208e-01_rb,2.714869e-01_rb,& + & 2.309516e-01_rb,2.012592e-01_rb,1.783315e-01_rb,1.600369e-01_rb,1.451000e-01_rb,& + & 1.326838e-01_rb,1.222069e-01_rb,1.132554e-01_rb,1.055146e-01_rb,9.876000e-02_rb,& + & 9.281386e-02_rb,8.754000e-02_rb,8.283078e-02_rb,7.860077e-02_rb,7.477769e-02_rb,& + & 7.130847e-02_rb,6.814461e-02_rb,6.524615e-02_rb,6.258462e-02_rb,6.012847e-02_rb,& + & 5.785462e-02_rb,5.574231e-02_rb,5.378000e-02_rb,5.194461e-02_rb,5.022462e-02_rb,& + & 4.860846e-02_rb,4.708462e-02_rb,4.564154e-02_rb,4.427462e-02_rb,4.297231e-02_rb,& + & 4.172769e-02_rb,4.053693e-02_rb,3.939000e-02_rb,3.828462e-02_rb,3.721692e-02_rb,& + & 3.618000e-02_rb,3.517077e-02_rb,3.418923e-02_rb,3.323077e-02_rb,3.229154e-02_rb,& + & 3.137154e-02_rb,3.047154e-02_rb,2.959077e-02_rb,2.872308e-02_rb,2.786846e-02_rb,& + & 2.703077e-02_rb,2.620923e-02_rb,2.540077e-02_rb,2.460615e-02_rb,2.382693e-02_rb,& + & 2.306231e-02_rb,2.231231e-02_rb,2.157923e-02_rb /) +! BAND 19 extliq1(:, 19) = (/ & - & 9.136931e-01_rb,5.743244e-01_rb,4.080708e-01_rb,3.150572e-01_rb,2.577261e-01_rb,& - & 2.197900e-01_rb,1.933037e-01_rb,1.740212e-01_rb,1.595056e-01_rb,1.482756e-01_rb,& - & 1.312164e-01_rb,1.209246e-01_rb,1.121227e-01_rb,1.045095e-01_rb,9.785967e-02_rb,& - & 9.200149e-02_rb,8.680170e-02_rb,8.215531e-02_rb,7.797850e-02_rb,7.420361e-02_rb,& - & 7.077530e-02_rb,6.764798e-02_rb,6.478369e-02_rb,6.215063e-02_rb,5.972189e-02_rb,& - & 5.747458e-02_rb,5.538913e-02_rb,5.344866e-02_rb,5.153216e-02_rb,4.989745e-02_rb,& - & 4.835476e-02_rb,4.689661e-02_rb,4.551629e-02_rb,4.420777e-02_rb,4.296563e-02_rb,& - & 4.178497e-02_rb,4.066137e-02_rb,3.959081e-02_rb,3.856963e-02_rb,3.759452e-02_rb,& - & 3.666244e-02_rb,3.577061e-02_rb,3.491650e-02_rb,3.409777e-02_rb,3.331227e-02_rb,& - & 3.255803e-02_rb,3.183322e-02_rb,3.113617e-02_rb,3.046530e-02_rb,2.981918e-02_rb,& - & 2.919646e-02_rb,2.859591e-02_rb,2.801635e-02_rb,2.745671e-02_rb,2.691599e-02_rb,& - & 2.639324e-02_rb,2.588759e-02_rb,2.5398e-02_rb /) + & 9.298960e-01_rb,5.776460e-01_rb,4.083450e-01_rb,3.211160e-01_rb,2.666390e-01_rb,& + & 2.281990e-01_rb,1.993250e-01_rb,1.768080e-01_rb,1.587810e-01_rb,1.440390e-01_rb,& + & 1.317720e-01_rb,1.214150e-01_rb,1.125540e-01_rb,1.048890e-01_rb,9.819600e-02_rb,& + & 9.230201e-02_rb,8.706900e-02_rb,8.239698e-02_rb,7.819500e-02_rb,7.439899e-02_rb,& + & 7.095300e-02_rb,6.780700e-02_rb,6.492900e-02_rb,6.228600e-02_rb,5.984600e-02_rb,& + & 5.758599e-02_rb,5.549099e-02_rb,5.353801e-02_rb,5.171400e-02_rb,5.000500e-02_rb,& + & 4.840000e-02_rb,4.688500e-02_rb,4.545100e-02_rb,4.409300e-02_rb,4.279700e-02_rb,& + & 4.156100e-02_rb,4.037700e-02_rb,3.923800e-02_rb,3.813800e-02_rb,3.707600e-02_rb,& + & 3.604500e-02_rb,3.504300e-02_rb,3.406500e-02_rb,3.310800e-02_rb,3.217700e-02_rb,& + & 3.126600e-02_rb,3.036800e-02_rb,2.948900e-02_rb,2.862400e-02_rb,2.777500e-02_rb,& + & 2.694200e-02_rb,2.612300e-02_rb,2.531700e-02_rb,2.452800e-02_rb,2.375100e-02_rb,& + & 2.299100e-02_rb,2.224300e-02_rb,2.151201e-02_rb /) +! BAND 20 extliq1(:, 20) = (/ & - & 8.447548e-01_rb,5.326840e-01_rb,3.921523e-01_rb,3.119082e-01_rb,2.597055e-01_rb,& - & 2.228737e-01_rb,1.954157e-01_rb,1.741155e-01_rb,1.570881e-01_rb,1.431520e-01_rb,& - & 1.302034e-01_rb,1.200491e-01_rb,1.113571e-01_rb,1.038330e-01_rb,9.725657e-02_rb,& - & 9.145949e-02_rb,8.631112e-02_rb,8.170840e-02_rb,7.756901e-02_rb,7.382641e-02_rb,& - & 7.042616e-02_rb,6.732338e-02_rb,6.448069e-02_rb,6.186672e-02_rb,5.945494e-02_rb,& - & 5.722277e-02_rb,5.515089e-02_rb,5.322262e-02_rb,5.132153e-02_rb,4.969799e-02_rb,& - & 4.816556e-02_rb,4.671686e-02_rb,4.534525e-02_rb,4.404480e-02_rb,4.281014e-02_rb,& - & 4.163643e-02_rb,4.051930e-02_rb,3.945479e-02_rb,3.843927e-02_rb,3.746945e-02_rb,& - & 3.654234e-02_rb,3.565518e-02_rb,3.480547e-02_rb,3.399088e-02_rb,3.320930e-02_rb,& - & 3.245876e-02_rb,3.173745e-02_rb,3.104371e-02_rb,3.037600e-02_rb,2.973287e-02_rb,& - & 2.911300e-02_rb,2.851516e-02_rb,2.793818e-02_rb,2.738101e-02_rb,2.684264e-02_rb,& - & 2.632214e-02_rb,2.581863e-02_rb,2.5331e-02_rb /) + & 8.780964e-01_rb,5.407031e-01_rb,3.961100e-01_rb,3.166645e-01_rb,2.640455e-01_rb,& + & 2.261070e-01_rb,1.974820e-01_rb,1.751775e-01_rb,1.573415e-01_rb,1.427725e-01_rb,& + & 1.306535e-01_rb,1.204195e-01_rb,1.116650e-01_rb,1.040915e-01_rb,9.747550e-02_rb,& + & 9.164800e-02_rb,8.647649e-02_rb,8.185501e-02_rb,7.770200e-02_rb,7.394749e-02_rb,& + & 7.053800e-02_rb,6.742700e-02_rb,6.457999e-02_rb,6.196149e-02_rb,5.954450e-02_rb,& + & 5.730650e-02_rb,5.522949e-02_rb,5.329450e-02_rb,5.148500e-02_rb,4.979000e-02_rb,& + & 4.819600e-02_rb,4.669301e-02_rb,4.527050e-02_rb,4.391899e-02_rb,4.263500e-02_rb,& + & 4.140500e-02_rb,4.022850e-02_rb,3.909500e-02_rb,3.800199e-02_rb,3.694600e-02_rb,& + & 3.592000e-02_rb,3.492250e-02_rb,3.395050e-02_rb,3.300150e-02_rb,3.207250e-02_rb,& + & 3.116250e-02_rb,3.027100e-02_rb,2.939500e-02_rb,2.853500e-02_rb,2.768900e-02_rb,& + & 2.686000e-02_rb,2.604350e-02_rb,2.524150e-02_rb,2.445350e-02_rb,2.368049e-02_rb,& + & 2.292150e-02_rb,2.217800e-02_rb,2.144800e-02_rb /) +! BAND 21 extliq1(:, 21) = (/ & - & 7.727642e-01_rb,5.034865e-01_rb,3.808673e-01_rb,3.080333e-01_rb,2.586453e-01_rb,& - & 2.224989e-01_rb,1.947060e-01_rb,1.725821e-01_rb,1.545096e-01_rb,1.394456e-01_rb,& - & 1.288683e-01_rb,1.188852e-01_rb,1.103317e-01_rb,1.029214e-01_rb,9.643967e-02_rb,& - & 9.072239e-02_rb,8.564194e-02_rb,8.109758e-02_rb,7.700875e-02_rb,7.331026e-02_rb,& - & 6.994879e-02_rb,6.688028e-02_rb,6.406807e-02_rb,6.148133e-02_rb,5.909400e-02_rb,& - & 5.688388e-02_rb,5.483197e-02_rb,5.292185e-02_rb,5.103763e-02_rb,4.942905e-02_rb,& - & 4.791039e-02_rb,4.647438e-02_rb,4.511453e-02_rb,4.382497e-02_rb,4.260043e-02_rb,& - & 4.143616e-02_rb,4.032784e-02_rb,3.927155e-02_rb,3.826375e-02_rb,3.730117e-02_rb,& - & 3.638087e-02_rb,3.550013e-02_rb,3.465646e-02_rb,3.384759e-02_rb,3.307141e-02_rb,& - & 3.232598e-02_rb,3.160953e-02_rb,3.092040e-02_rb,3.025706e-02_rb,2.961810e-02_rb,& - & 2.900220e-02_rb,2.840814e-02_rb,2.783478e-02_rb,2.728106e-02_rb,2.674599e-02_rb,& - & 2.622864e-02_rb,2.572816e-02_rb,2.5244e-02_rb /) + & 7.937480e-01_rb,5.123036e-01_rb,3.858181e-01_rb,3.099622e-01_rb,2.586829e-01_rb,& + & 2.217587e-01_rb,1.939755e-01_rb,1.723397e-01_rb,1.550258e-01_rb,1.408600e-01_rb,& + & 1.290545e-01_rb,1.190661e-01_rb,1.105039e-01_rb,1.030848e-01_rb,9.659387e-02_rb,& + & 9.086775e-02_rb,8.577807e-02_rb,8.122452e-02_rb,7.712711e-02_rb,7.342193e-02_rb,& + & 7.005387e-02_rb,6.697840e-02_rb,6.416000e-02_rb,6.156903e-02_rb,5.917484e-02_rb,& + & 5.695807e-02_rb,5.489968e-02_rb,5.298097e-02_rb,5.118806e-02_rb,4.950645e-02_rb,& + & 4.792710e-02_rb,4.643581e-02_rb,4.502484e-02_rb,4.368547e-02_rb,4.241001e-02_rb,& + & 4.118936e-02_rb,4.002193e-02_rb,3.889711e-02_rb,3.781322e-02_rb,3.676387e-02_rb,& + & 3.574549e-02_rb,3.475548e-02_rb,3.379033e-02_rb,3.284678e-02_rb,3.192420e-02_rb,& + & 3.102032e-02_rb,3.013484e-02_rb,2.926258e-02_rb,2.840839e-02_rb,2.756742e-02_rb,& + & 2.674258e-02_rb,2.593064e-02_rb,2.513258e-02_rb,2.435000e-02_rb,2.358064e-02_rb,& + & 2.282581e-02_rb,2.208548e-02_rb,2.135936e-02_rb /) +! BAND 22 extliq1(:, 22) = (/ & - & 7.416833e-01_rb,4.959591e-01_rb,3.775057e-01_rb,3.056353e-01_rb,2.565943e-01_rb,& - & 2.206935e-01_rb,1.931479e-01_rb,1.712860e-01_rb,1.534837e-01_rb,1.386906e-01_rb,& - & 1.281198e-01_rb,1.182344e-01_rb,1.097595e-01_rb,1.024137e-01_rb,9.598552e-02_rb,& - & 9.031320e-02_rb,8.527093e-02_rb,8.075927e-02_rb,7.669869e-02_rb,7.302481e-02_rb,& - & 6.968491e-02_rb,6.663542e-02_rb,6.384008e-02_rb,6.126838e-02_rb,5.889452e-02_rb,& - & 5.669654e-02_rb,5.465558e-02_rb,5.275540e-02_rb,5.087937e-02_rb,4.927904e-02_rb,& - & 4.776796e-02_rb,4.633895e-02_rb,4.498557e-02_rb,4.370202e-02_rb,4.248306e-02_rb,& - & 4.132399e-02_rb,4.022052e-02_rb,3.916878e-02_rb,3.816523e-02_rb,3.720665e-02_rb,& - & 3.629011e-02_rb,3.541290e-02_rb,3.457257e-02_rb,3.376685e-02_rb,3.299365e-02_rb,& - & 3.225105e-02_rb,3.153728e-02_rb,3.085069e-02_rb,3.018977e-02_rb,2.955310e-02_rb,& - & 2.893940e-02_rb,2.834742e-02_rb,2.777606e-02_rb,2.722424e-02_rb,2.669099e-02_rb,& - & 2.617539e-02_rb,2.567658e-02_rb,2.5194e-02_rb /) + & 7.533129e-01_rb,5.033129e-01_rb,3.811271e-01_rb,3.062757e-01_rb,2.558729e-01_rb,& + & 2.196828e-01_rb,1.924372e-01_rb,1.711714e-01_rb,1.541086e-01_rb,1.401114e-01_rb,& + & 1.284257e-01_rb,1.185200e-01_rb,1.100243e-01_rb,1.026529e-01_rb,9.620142e-02_rb,& + & 9.050714e-02_rb,8.544428e-02_rb,8.091714e-02_rb,7.684000e-02_rb,7.315429e-02_rb,& + & 6.980143e-02_rb,6.673999e-02_rb,6.394000e-02_rb,6.136000e-02_rb,5.897715e-02_rb,& + & 5.677000e-02_rb,5.472285e-02_rb,5.281286e-02_rb,5.102858e-02_rb,4.935429e-02_rb,& + & 4.778000e-02_rb,4.629714e-02_rb,4.489142e-02_rb,4.355857e-02_rb,4.228715e-02_rb,& + & 4.107285e-02_rb,3.990857e-02_rb,3.879000e-02_rb,3.770999e-02_rb,3.666429e-02_rb,& + & 3.565000e-02_rb,3.466286e-02_rb,3.370143e-02_rb,3.276143e-02_rb,3.184143e-02_rb,& + & 3.094000e-02_rb,3.005714e-02_rb,2.919000e-02_rb,2.833714e-02_rb,2.750000e-02_rb,& + & 2.667714e-02_rb,2.586714e-02_rb,2.507143e-02_rb,2.429143e-02_rb,2.352428e-02_rb,& + & 2.277143e-02_rb,2.203429e-02_rb,2.130857e-02_rb /) +! BAND 23 extliq1(:, 23) = (/ & - & 7.058580e-01_rb,4.866573e-01_rb,3.712238e-01_rb,2.998638e-01_rb,2.513441e-01_rb,& - & 2.161972e-01_rb,1.895576e-01_rb,1.686669e-01_rb,1.518437e-01_rb,1.380046e-01_rb,& - & 1.267564e-01_rb,1.170399e-01_rb,1.087026e-01_rb,1.014704e-01_rb,9.513729e-02_rb,& - & 8.954555e-02_rb,8.457221e-02_rb,8.012009e-02_rb,7.611136e-02_rb,7.248294e-02_rb,& - & 6.918317e-02_rb,6.616934e-02_rb,6.340584e-02_rb,6.086273e-02_rb,5.851465e-02_rb,& - & 5.634001e-02_rb,5.432027e-02_rb,5.243946e-02_rb,5.058070e-02_rb,4.899628e-02_rb,& - & 4.749975e-02_rb,4.608411e-02_rb,4.474303e-02_rb,4.347082e-02_rb,4.226237e-02_rb,& - & 4.111303e-02_rb,4.001861e-02_rb,3.897528e-02_rb,3.797959e-02_rb,3.702835e-02_rb,& - & 3.611867e-02_rb,3.524791e-02_rb,3.441364e-02_rb,3.361360e-02_rb,3.284577e-02_rb,& - & 3.210823e-02_rb,3.139923e-02_rb,3.071716e-02_rb,3.006052e-02_rb,2.942791e-02_rb,& - & 2.881806e-02_rb,2.822974e-02_rb,2.766185e-02_rb,2.711335e-02_rb,2.658326e-02_rb,& - & 2.607066e-02_rb,2.557473e-02_rb,2.5095e-02_rb /) + & 7.079894e-01_rb,4.878198e-01_rb,3.719852e-01_rb,3.001873e-01_rb,2.514795e-01_rb,& + & 2.163013e-01_rb,1.897100e-01_rb,1.689033e-01_rb,1.521793e-01_rb,1.384449e-01_rb,& + & 1.269666e-01_rb,1.172326e-01_rb,1.088745e-01_rb,1.016224e-01_rb,9.527085e-02_rb,& + & 8.966240e-02_rb,8.467543e-02_rb,8.021144e-02_rb,7.619344e-02_rb,7.255676e-02_rb,& + & 6.924996e-02_rb,6.623030e-02_rb,6.346261e-02_rb,6.091499e-02_rb,5.856325e-02_rb,& + & 5.638385e-02_rb,5.435930e-02_rb,5.247156e-02_rb,5.070699e-02_rb,4.905230e-02_rb,& + & 4.749499e-02_rb,4.602611e-02_rb,4.463581e-02_rb,4.331543e-02_rb,4.205647e-02_rb,& + & 4.085241e-02_rb,3.969978e-02_rb,3.859033e-02_rb,3.751877e-02_rb,3.648168e-02_rb,& + & 3.547468e-02_rb,3.449553e-02_rb,3.354072e-02_rb,3.260732e-02_rb,3.169438e-02_rb,& + & 3.079969e-02_rb,2.992146e-02_rb,2.905875e-02_rb,2.821201e-02_rb,2.737873e-02_rb,& + & 2.656052e-02_rb,2.575586e-02_rb,2.496511e-02_rb,2.418783e-02_rb,2.342500e-02_rb,& + & 2.267646e-02_rb,2.194177e-02_rb,2.122146e-02_rb /) +! BAND 24 extliq1(:, 24) = (/ & - & 6.822779e-01_rb,4.750373e-01_rb,3.634834e-01_rb,2.940726e-01_rb,2.468060e-01_rb,& - & 2.125768e-01_rb,1.866586e-01_rb,1.663588e-01_rb,1.500326e-01_rb,1.366192e-01_rb,& - & 1.253472e-01_rb,1.158052e-01_rb,1.076101e-01_rb,1.004954e-01_rb,9.426089e-02_rb,& - & 8.875268e-02_rb,8.385090e-02_rb,7.946063e-02_rb,7.550578e-02_rb,7.192466e-02_rb,& - & 6.866669e-02_rb,6.569001e-02_rb,6.295971e-02_rb,6.044642e-02_rb,5.812526e-02_rb,& - & 5.597500e-02_rb,5.397746e-02_rb,5.211690e-02_rb,5.027505e-02_rb,4.870703e-02_rb,& - & 4.722555e-02_rb,4.582373e-02_rb,4.449540e-02_rb,4.323497e-02_rb,4.203742e-02_rb,& - & 4.089821e-02_rb,3.981321e-02_rb,3.877867e-02_rb,3.779118e-02_rb,3.684762e-02_rb,& - & 3.594514e-02_rb,3.508114e-02_rb,3.425322e-02_rb,3.345917e-02_rb,3.269698e-02_rb,& - & 3.196477e-02_rb,3.126082e-02_rb,3.058352e-02_rb,2.993141e-02_rb,2.930310e-02_rb,& - & 2.869732e-02_rb,2.811289e-02_rb,2.754869e-02_rb,2.700371e-02_rb,2.647698e-02_rb,& - & 2.596760e-02_rb,2.547473e-02_rb,2.4998e-02_rb /) + & 6.850164e-01_rb,4.762468e-01_rb,3.642001e-01_rb,2.946012e-01_rb,2.472001e-01_rb,& + & 2.128588e-01_rb,1.868537e-01_rb,1.664893e-01_rb,1.501142e-01_rb,1.366620e-01_rb,& + & 1.254147e-01_rb,1.158721e-01_rb,1.076732e-01_rb,1.005530e-01_rb,9.431306e-02_rb,& + & 8.879891e-02_rb,8.389232e-02_rb,7.949714e-02_rb,7.553857e-02_rb,7.195474e-02_rb,& + & 6.869413e-02_rb,6.571444e-02_rb,6.298286e-02_rb,6.046779e-02_rb,5.814474e-02_rb,& + & 5.599141e-02_rb,5.399114e-02_rb,5.212443e-02_rb,5.037870e-02_rb,4.874321e-02_rb,& + & 4.720219e-02_rb,4.574813e-02_rb,4.437160e-02_rb,4.306460e-02_rb,4.181810e-02_rb,& + & 4.062603e-02_rb,3.948252e-02_rb,3.838256e-02_rb,3.732049e-02_rb,3.629192e-02_rb,& + & 3.529301e-02_rb,3.432190e-02_rb,3.337412e-02_rb,3.244842e-02_rb,3.154175e-02_rb,& + & 3.065253e-02_rb,2.978063e-02_rb,2.892367e-02_rb,2.808221e-02_rb,2.725478e-02_rb,& + & 2.644174e-02_rb,2.564175e-02_rb,2.485508e-02_rb,2.408303e-02_rb,2.332365e-02_rb,& + & 2.257890e-02_rb,2.184824e-02_rb,2.113224e-02_rb /) +! BAND 25 extliq1(:, 25) = (/ & - & 6.666233e-01_rb,4.662044e-01_rb,3.579517e-01_rb,2.902984e-01_rb,2.440475e-01_rb,& - & 2.104431e-01_rb,1.849277e-01_rb,1.648970e-01_rb,1.487555e-01_rb,1.354714e-01_rb,& - & 1.244173e-01_rb,1.149913e-01_rb,1.068903e-01_rb,9.985323e-02_rb,9.368351e-02_rb,& - & 8.823009e-02_rb,8.337507e-02_rb,7.902511e-02_rb,7.510529e-02_rb,7.155482e-02_rb,& - & 6.832386e-02_rb,6.537113e-02_rb,6.266218e-02_rb,6.016802e-02_rb,5.786408e-02_rb,& - & 5.572939e-02_rb,5.374598e-02_rb,5.189830e-02_rb,5.006825e-02_rb,4.851081e-02_rb,& - & 4.703906e-02_rb,4.564623e-02_rb,4.432621e-02_rb,4.307349e-02_rb,4.188312e-02_rb,& - & 4.075060e-02_rb,3.967183e-02_rb,3.864313e-02_rb,3.766111e-02_rb,3.672269e-02_rb,& - & 3.582505e-02_rb,3.496559e-02_rb,3.414196e-02_rb,3.335198e-02_rb,3.259362e-02_rb,& - & 3.186505e-02_rb,3.116454e-02_rb,3.049052e-02_rb,2.984152e-02_rb,2.921617e-02_rb,& - & 2.861322e-02_rb,2.803148e-02_rb,2.746986e-02_rb,2.692733e-02_rb,2.640295e-02_rb,& - & 2.589582e-02_rb,2.540510e-02_rb,2.4930e-02_rb /) + & 6.673017e-01_rb,4.664520e-01_rb,3.579398e-01_rb,2.902234e-01_rb,2.439904e-01_rb,& + & 2.104149e-01_rb,1.849277e-01_rb,1.649234e-01_rb,1.488087e-01_rb,1.355515e-01_rb,& + & 1.244562e-01_rb,1.150329e-01_rb,1.069321e-01_rb,9.989310e-02_rb,9.372070e-02_rb,& + & 8.826450e-02_rb,8.340622e-02_rb,7.905378e-02_rb,7.513109e-02_rb,7.157859e-02_rb,& + & 6.834588e-02_rb,6.539114e-02_rb,6.268150e-02_rb,6.018621e-02_rb,5.788098e-02_rb,& + & 5.574351e-02_rb,5.375699e-02_rb,5.190412e-02_rb,5.017099e-02_rb,4.854497e-02_rb,& + & 4.701490e-02_rb,4.557030e-02_rb,4.420249e-02_rb,4.290304e-02_rb,4.166427e-02_rb,& + & 4.047820e-02_rb,3.934232e-02_rb,3.824778e-02_rb,3.719236e-02_rb,3.616931e-02_rb,& + & 3.517597e-02_rb,3.420856e-02_rb,3.326566e-02_rb,3.234346e-02_rb,3.144122e-02_rb,& + & 3.055684e-02_rb,2.968798e-02_rb,2.883519e-02_rb,2.799635e-02_rb,2.717228e-02_rb,& + & 2.636182e-02_rb,2.556424e-02_rb,2.478114e-02_rb,2.401086e-02_rb,2.325657e-02_rb,& + & 2.251506e-02_rb,2.178594e-02_rb,2.107301e-02_rb /) +! BAND 26 extliq1(:, 26) = (/ & - & 6.535669e-01_rb,4.585865e-01_rb,3.529226e-01_rb,2.867245e-01_rb,2.413848e-01_rb,& - & 2.083956e-01_rb,1.833191e-01_rb,1.636150e-01_rb,1.477247e-01_rb,1.346392e-01_rb,& - & 1.236449e-01_rb,1.143095e-01_rb,1.062828e-01_rb,9.930773e-02_rb,9.319029e-02_rb,& - & 8.778150e-02_rb,8.296497e-02_rb,7.864847e-02_rb,7.475799e-02_rb,7.123343e-02_rb,& - & 6.802549e-02_rb,6.509332e-02_rb,6.240285e-02_rb,5.992538e-02_rb,5.763657e-02_rb,& - & 5.551566e-02_rb,5.354483e-02_rb,5.170870e-02_rb,4.988866e-02_rb,4.834061e-02_rb,& - & 4.687751e-02_rb,4.549264e-02_rb,4.417999e-02_rb,4.293410e-02_rb,4.175006e-02_rb,& - & 4.062344e-02_rb,3.955019e-02_rb,3.852663e-02_rb,3.754943e-02_rb,3.661553e-02_rb,& - & 3.572214e-02_rb,3.486669e-02_rb,3.404683e-02_rb,3.326040e-02_rb,3.250542e-02_rb,& - & 3.178003e-02_rb,3.108254e-02_rb,3.041139e-02_rb,2.976511e-02_rb,2.914235e-02_rb,& - & 2.854187e-02_rb,2.796247e-02_rb,2.740309e-02_rb,2.686271e-02_rb,2.634038e-02_rb,& - & 2.583520e-02_rb,2.534636e-02_rb,2.4873e-02_rb /) + & 6.552414e-01_rb,4.599454e-01_rb,3.538626e-01_rb,2.873547e-01_rb,2.418033e-01_rb,& + & 2.086660e-01_rb,1.834885e-01_rb,1.637142e-01_rb,1.477767e-01_rb,1.346583e-01_rb,& + & 1.236734e-01_rb,1.143412e-01_rb,1.063148e-01_rb,9.933905e-02_rb,9.322026e-02_rb,& + & 8.780979e-02_rb,8.299230e-02_rb,7.867554e-02_rb,7.478450e-02_rb,7.126053e-02_rb,& + & 6.805276e-02_rb,6.512143e-02_rb,6.243211e-02_rb,5.995541e-02_rb,5.766712e-02_rb,& + & 5.554484e-02_rb,5.357246e-02_rb,5.173222e-02_rb,5.001069e-02_rb,4.839505e-02_rb,& + & 4.687471e-02_rb,4.543861e-02_rb,4.407857e-02_rb,4.278577e-02_rb,4.155331e-02_rb,& + & 4.037322e-02_rb,3.924302e-02_rb,3.815376e-02_rb,3.710172e-02_rb,3.608296e-02_rb,& + & 3.509330e-02_rb,3.412980e-02_rb,3.319009e-02_rb,3.227106e-02_rb,3.137157e-02_rb,& + & 3.048950e-02_rb,2.962365e-02_rb,2.877297e-02_rb,2.793726e-02_rb,2.711500e-02_rb,& + & 2.630666e-02_rb,2.551206e-02_rb,2.473052e-02_rb,2.396287e-02_rb,2.320861e-02_rb,& + & 2.246810e-02_rb,2.174162e-02_rb,2.102927e-02_rb /) +! BAND 27 extliq1(:, 27) = (/ & - & 6.448790e-01_rb,4.541425e-01_rb,3.503348e-01_rb,2.850494e-01_rb,2.401966e-01_rb,& - & 2.074811e-01_rb,1.825631e-01_rb,1.629515e-01_rb,1.471142e-01_rb,1.340574e-01_rb,& - & 1.231462e-01_rb,1.138628e-01_rb,1.058802e-01_rb,9.894286e-02_rb,9.285818e-02_rb,& - & 8.747802e-02_rb,8.268676e-02_rb,7.839271e-02_rb,7.452230e-02_rb,7.101580e-02_rb,& - & 6.782418e-02_rb,6.490685e-02_rb,6.222991e-02_rb,5.976484e-02_rb,5.748742e-02_rb,& - & 5.537703e-02_rb,5.341593e-02_rb,5.158883e-02_rb,4.977355e-02_rb,4.823172e-02_rb,& - & 4.677430e-02_rb,4.539465e-02_rb,4.408680e-02_rb,4.284533e-02_rb,4.166539e-02_rb,& - & 4.054257e-02_rb,3.947283e-02_rb,3.845256e-02_rb,3.747842e-02_rb,3.654737e-02_rb,& - & 3.565665e-02_rb,3.480370e-02_rb,3.398620e-02_rb,3.320198e-02_rb,3.244908e-02_rb,& - & 3.172566e-02_rb,3.103002e-02_rb,3.036062e-02_rb,2.971600e-02_rb,2.909482e-02_rb,& - & 2.849582e-02_rb,2.791785e-02_rb,2.735982e-02_rb,2.682072e-02_rb,2.629960e-02_rb,& - & 2.579559e-02_rb,2.530786e-02_rb,2.4836e-02_rb /) + & 6.430901e-01_rb,4.532134e-01_rb,3.496132e-01_rb,2.844655e-01_rb,2.397347e-01_rb,& + & 2.071236e-01_rb,1.822976e-01_rb,1.627640e-01_rb,1.469961e-01_rb,1.340006e-01_rb,& + & 1.231069e-01_rb,1.138441e-01_rb,1.058706e-01_rb,9.893678e-02_rb,9.285166e-02_rb,& + & 8.746871e-02_rb,8.267411e-02_rb,7.837656e-02_rb,7.450257e-02_rb,7.099318e-02_rb,& + & 6.779929e-02_rb,6.487987e-02_rb,6.220168e-02_rb,5.973530e-02_rb,5.745636e-02_rb,& + & 5.534344e-02_rb,5.337986e-02_rb,5.154797e-02_rb,4.983404e-02_rb,4.822582e-02_rb,& + & 4.671228e-02_rb,4.528321e-02_rb,4.392997e-02_rb,4.264325e-02_rb,4.141647e-02_rb,& + & 4.024259e-02_rb,3.911767e-02_rb,3.803309e-02_rb,3.698782e-02_rb,3.597140e-02_rb,& + & 3.498774e-02_rb,3.402852e-02_rb,3.309340e-02_rb,3.217818e-02_rb,3.128292e-02_rb,& + & 3.040486e-02_rb,2.954230e-02_rb,2.869545e-02_rb,2.786261e-02_rb,2.704372e-02_rb,& + & 2.623813e-02_rb,2.544668e-02_rb,2.466788e-02_rb,2.390313e-02_rb,2.315136e-02_rb,& + & 2.241391e-02_rb,2.168921e-02_rb,2.097903e-02_rb /) +! BAND 28 extliq1(:, 28) = (/ & - & 6.422688e-01_rb,4.528453e-01_rb,3.497232e-01_rb,2.847724e-01_rb,2.400815e-01_rb,& - & 2.074403e-01_rb,1.825502e-01_rb,1.629415e-01_rb,1.470934e-01_rb,1.340183e-01_rb,& - & 1.230935e-01_rb,1.138049e-01_rb,1.058201e-01_rb,9.888245e-02_rb,9.279878e-02_rb,& - & 8.742053e-02_rb,8.263175e-02_rb,7.834058e-02_rb,7.447327e-02_rb,7.097000e-02_rb,& - & 6.778167e-02_rb,6.486765e-02_rb,6.219400e-02_rb,5.973215e-02_rb,5.745790e-02_rb,& - & 5.535059e-02_rb,5.339250e-02_rb,5.156831e-02_rb,4.975308e-02_rb,4.821235e-02_rb,& - & 4.675596e-02_rb,4.537727e-02_rb,4.407030e-02_rb,4.282968e-02_rb,4.165053e-02_rb,& - & 4.052845e-02_rb,3.945941e-02_rb,3.843980e-02_rb,3.746628e-02_rb,3.653583e-02_rb,& - & 3.564567e-02_rb,3.479326e-02_rb,3.397626e-02_rb,3.319253e-02_rb,3.244008e-02_rb,& - & 3.171711e-02_rb,3.102189e-02_rb,3.035289e-02_rb,2.970866e-02_rb,2.908784e-02_rb,& - & 2.848920e-02_rb,2.791156e-02_rb,2.735385e-02_rb,2.681507e-02_rb,2.629425e-02_rb,& - & 2.579053e-02_rb,2.530308e-02_rb,2.4831e-02_rb /) + & 6.367074e-01_rb,4.495768e-01_rb,3.471263e-01_rb,2.826149e-01_rb,2.382868e-01_rb,& + & 2.059640e-01_rb,1.813562e-01_rb,1.619881e-01_rb,1.463436e-01_rb,1.334402e-01_rb,& + & 1.226166e-01_rb,1.134096e-01_rb,1.054829e-01_rb,9.858838e-02_rb,9.253790e-02_rb,& + & 8.718582e-02_rb,8.241830e-02_rb,7.814482e-02_rb,7.429212e-02_rb,7.080165e-02_rb,& + & 6.762385e-02_rb,6.471838e-02_rb,6.205388e-02_rb,5.959726e-02_rb,5.732871e-02_rb,& + & 5.522402e-02_rb,5.326793e-02_rb,5.144230e-02_rb,4.973440e-02_rb,4.813188e-02_rb,& + & 4.662283e-02_rb,4.519798e-02_rb,4.384833e-02_rb,4.256541e-02_rb,4.134253e-02_rb,& + & 4.017136e-02_rb,3.904911e-02_rb,3.796779e-02_rb,3.692364e-02_rb,3.591182e-02_rb,& + & 3.492930e-02_rb,3.397230e-02_rb,3.303920e-02_rb,3.212572e-02_rb,3.123278e-02_rb,& + & 3.035519e-02_rb,2.949493e-02_rb,2.864985e-02_rb,2.781840e-02_rb,2.700197e-02_rb,& + & 2.619682e-02_rb,2.540674e-02_rb,2.462966e-02_rb,2.386613e-02_rb,2.311602e-02_rb,& + & 2.237846e-02_rb,2.165660e-02_rb,2.094756e-02_rb /) +! BAND 29 extliq1(:, 29) = (/ & - & 4.614710e-01_rb,4.556116e-01_rb,4.056568e-01_rb,3.529833e-01_rb,3.060334e-01_rb,& - & 2.658127e-01_rb,2.316095e-01_rb,2.024325e-01_rb,1.773749e-01_rb,1.556867e-01_rb,& - & 1.455558e-01_rb,1.332882e-01_rb,1.229052e-01_rb,1.140067e-01_rb,1.062981e-01_rb,& - & 9.955703e-02_rb,9.361333e-02_rb,8.833420e-02_rb,8.361467e-02_rb,7.937071e-02_rb,& - & 7.553420e-02_rb,7.204942e-02_rb,6.887031e-02_rb,6.595851e-02_rb,6.328178e-02_rb,& - & 6.081286e-02_rb,5.852854e-02_rb,5.640892e-02_rb,5.431269e-02_rb,5.252561e-02_rb,& - & 5.084345e-02_rb,4.925727e-02_rb,4.775910e-02_rb,4.634182e-02_rb,4.499907e-02_rb,& - & 4.372512e-02_rb,4.251484e-02_rb,4.136357e-02_rb,4.026710e-02_rb,3.922162e-02_rb,& - & 3.822365e-02_rb,3.727004e-02_rb,3.635790e-02_rb,3.548457e-02_rb,3.464764e-02_rb,& - & 3.384488e-02_rb,3.307424e-02_rb,3.233384e-02_rb,3.162192e-02_rb,3.093688e-02_rb,& - & 3.027723e-02_rb,2.964158e-02_rb,2.902864e-02_rb,2.843722e-02_rb,2.786621e-02_rb,& - & 2.731457e-02_rb,2.678133e-02_rb,2.6266e-02_rb /) - -! Single scattering albedo + & 4.298416e-01_rb,4.391639e-01_rb,3.975030e-01_rb,3.443028e-01_rb,2.957345e-01_rb,& + & 2.556461e-01_rb,2.234755e-01_rb,1.976636e-01_rb,1.767428e-01_rb,1.595611e-01_rb,& + & 1.452636e-01_rb,1.332156e-01_rb,1.229481e-01_rb,1.141059e-01_rb,1.064208e-01_rb,& + & 9.968527e-02_rb,9.373833e-02_rb,8.845221e-02_rb,8.372112e-02_rb,7.946667e-02_rb,& + & 7.561807e-02_rb,7.212029e-02_rb,6.893166e-02_rb,6.600944e-02_rb,6.332277e-02_rb,& + & 6.084277e-02_rb,5.854721e-02_rb,5.641361e-02_rb,5.442639e-02_rb,5.256750e-02_rb,& + & 5.082499e-02_rb,4.918556e-02_rb,4.763694e-02_rb,4.617222e-02_rb,4.477861e-02_rb,& + & 4.344861e-02_rb,4.217999e-02_rb,4.096111e-02_rb,3.978638e-02_rb,3.865361e-02_rb,& + & 3.755473e-02_rb,3.649028e-02_rb,3.545361e-02_rb,3.444361e-02_rb,3.345666e-02_rb,& + & 3.249167e-02_rb,3.154722e-02_rb,3.062083e-02_rb,2.971250e-02_rb,2.882083e-02_rb,& + & 2.794611e-02_rb,2.708778e-02_rb,2.624500e-02_rb,2.541750e-02_rb,2.460528e-02_rb,& + & 2.381194e-02_rb,2.303250e-02_rb,2.226833e-02_rb /) +! BAND 16 ssaliq1(:, 16) = (/ & - & 8.143821e-01_rb,7.836739e-01_rb,7.550722e-01_rb,7.306269e-01_rb,7.105612e-01_rb,& - & 6.946649e-01_rb,6.825556e-01_rb,6.737762e-01_rb,6.678448e-01_rb,6.642830e-01_rb,& - & 6.679741e-01_rb,6.584607e-01_rb,6.505598e-01_rb,6.440951e-01_rb,6.388901e-01_rb,& - & 6.347689e-01_rb,6.315549e-01_rb,6.290718e-01_rb,6.271432e-01_rb,6.255928e-01_rb,& - & 6.242441e-01_rb,6.229207e-01_rb,6.214464e-01_rb,6.196445e-01_rb,6.173388e-01_rb,& - & 6.143527e-01_rb,6.105099e-01_rb,6.056339e-01_rb,6.108290e-01_rb,6.073939e-01_rb,& - & 6.043073e-01_rb,6.015473e-01_rb,5.990913e-01_rb,5.969173e-01_rb,5.950028e-01_rb,& - & 5.933257e-01_rb,5.918636e-01_rb,5.905944e-01_rb,5.894957e-01_rb,5.885453e-01_rb,& - & 5.877209e-01_rb,5.870003e-01_rb,5.863611e-01_rb,5.857811e-01_rb,5.852381e-01_rb,& - & 5.847098e-01_rb,5.841738e-01_rb,5.836081e-01_rb,5.829901e-01_rb,5.822979e-01_rb,& - & 5.815089e-01_rb,5.806011e-01_rb,5.795521e-01_rb,5.783396e-01_rb,5.769413e-01_rb,& - & 5.753351e-01_rb,5.734986e-01_rb,5.7141e-01_rb /) + & 8.362119e-01_rb,8.098460e-01_rb,7.762291e-01_rb,7.486042e-01_rb,7.294172e-01_rb,& + & 7.161000e-01_rb,7.060656e-01_rb,6.978387e-01_rb,6.907193e-01_rb,6.843551e-01_rb,& + & 6.785668e-01_rb,6.732450e-01_rb,6.683191e-01_rb,6.637264e-01_rb,6.594307e-01_rb,& + & 6.554033e-01_rb,6.516115e-01_rb,6.480295e-01_rb,6.446429e-01_rb,6.414306e-01_rb,& + & 6.383783e-01_rb,6.354750e-01_rb,6.327068e-01_rb,6.300665e-01_rb,6.275376e-01_rb,& + & 6.251245e-01_rb,6.228136e-01_rb,6.205944e-01_rb,6.184720e-01_rb,6.164330e-01_rb,& + & 6.144742e-01_rb,6.125962e-01_rb,6.108004e-01_rb,6.090740e-01_rb,6.074200e-01_rb,& + & 6.058381e-01_rb,6.043209e-01_rb,6.028681e-01_rb,6.014836e-01_rb,6.001626e-01_rb,& + & 5.988957e-01_rb,5.976864e-01_rb,5.965390e-01_rb,5.954379e-01_rb,5.943972e-01_rb,& + & 5.934019e-01_rb,5.924624e-01_rb,5.915579e-01_rb,5.907025e-01_rb,5.898913e-01_rb,& + & 5.891213e-01_rb,5.883815e-01_rb,5.876851e-01_rb,5.870158e-01_rb,5.863868e-01_rb,& + & 5.857821e-01_rb,5.852111e-01_rb,5.846579e-01_rb /) +! BAND 17 ssaliq1(:, 17) = (/ & - & 8.165821e-01_rb,8.002015e-01_rb,7.816921e-01_rb,7.634131e-01_rb,7.463721e-01_rb,& - & 7.312469e-01_rb,7.185883e-01_rb,7.088975e-01_rb,7.026671e-01_rb,7.004020e-01_rb,& - & 7.042138e-01_rb,6.960930e-01_rb,6.894243e-01_rb,6.840459e-01_rb,6.797957e-01_rb,& - & 6.765119e-01_rb,6.740325e-01_rb,6.721955e-01_rb,6.708391e-01_rb,6.698013e-01_rb,& - & 6.689201e-01_rb,6.680339e-01_rb,6.669805e-01_rb,6.655982e-01_rb,6.637250e-01_rb,& - & 6.611992e-01_rb,6.578588e-01_rb,6.535420e-01_rb,6.584449e-01_rb,6.553992e-01_rb,& - & 6.526547e-01_rb,6.501917e-01_rb,6.479905e-01_rb,6.460313e-01_rb,6.442945e-01_rb,& - & 6.427605e-01_rb,6.414094e-01_rb,6.402217e-01_rb,6.391775e-01_rb,6.382573e-01_rb,& - & 6.374413e-01_rb,6.367099e-01_rb,6.360433e-01_rb,6.354218e-01_rb,6.348257e-01_rb,& - & 6.342355e-01_rb,6.336313e-01_rb,6.329935e-01_rb,6.323023e-01_rb,6.315383e-01_rb,& - & 6.306814e-01_rb,6.297122e-01_rb,6.286110e-01_rb,6.273579e-01_rb,6.259333e-01_rb,& - & 6.243176e-01_rb,6.224910e-01_rb,6.2043e-01_rb /) + & 6.995459e-01_rb,7.158012e-01_rb,7.076001e-01_rb,6.927244e-01_rb,6.786434e-01_rb,& + & 6.673545e-01_rb,6.585859e-01_rb,6.516314e-01_rb,6.459010e-01_rb,6.410225e-01_rb,& + & 6.367574e-01_rb,6.329554e-01_rb,6.295119e-01_rb,6.263595e-01_rb,6.234462e-01_rb,& + & 6.207274e-01_rb,6.181755e-01_rb,6.157678e-01_rb,6.134880e-01_rb,6.113173e-01_rb,& + & 6.092495e-01_rb,6.072689e-01_rb,6.053717e-01_rb,6.035507e-01_rb,6.018001e-01_rb,& + & 6.001134e-01_rb,5.984951e-01_rb,5.969294e-01_rb,5.954256e-01_rb,5.939698e-01_rb,& + & 5.925716e-01_rb,5.912265e-01_rb,5.899270e-01_rb,5.886771e-01_rb,5.874746e-01_rb,& + & 5.863185e-01_rb,5.852077e-01_rb,5.841460e-01_rb,5.831249e-01_rb,5.821474e-01_rb,& + & 5.812078e-01_rb,5.803173e-01_rb,5.794616e-01_rb,5.786443e-01_rb,5.778617e-01_rb,& + & 5.771236e-01_rb,5.764191e-01_rb,5.757400e-01_rb,5.750971e-01_rb,5.744842e-01_rb,& + & 5.739012e-01_rb,5.733482e-01_rb,5.728175e-01_rb,5.723214e-01_rb,5.718383e-01_rb,& + & 5.713827e-01_rb,5.709471e-01_rb,5.705330e-01_rb /) +! BAND 18 ssaliq1(:, 18) = (/ & - & 9.900163e-01_rb,9.854307e-01_rb,9.797730e-01_rb,9.733113e-01_rb,9.664245e-01_rb,& - & 9.594976e-01_rb,9.529055e-01_rb,9.470112e-01_rb,9.421695e-01_rb,9.387304e-01_rb,& - & 9.344918e-01_rb,9.305302e-01_rb,9.267048e-01_rb,9.230072e-01_rb,9.194289e-01_rb,& - & 9.159616e-01_rb,9.125968e-01_rb,9.093260e-01_rb,9.061409e-01_rb,9.030330e-01_rb,& - & 8.999940e-01_rb,8.970154e-01_rb,8.940888e-01_rb,8.912058e-01_rb,8.883579e-01_rb,& - & 8.855368e-01_rb,8.827341e-01_rb,8.799413e-01_rb,8.777423e-01_rb,8.749566e-01_rb,& - & 8.722298e-01_rb,8.695605e-01_rb,8.669469e-01_rb,8.643875e-01_rb,8.618806e-01_rb,& - & 8.594246e-01_rb,8.570179e-01_rb,8.546589e-01_rb,8.523459e-01_rb,8.500773e-01_rb,& - & 8.478516e-01_rb,8.456670e-01_rb,8.435219e-01_rb,8.414148e-01_rb,8.393439e-01_rb,& - & 8.373078e-01_rb,8.353047e-01_rb,8.333330e-01_rb,8.313911e-01_rb,8.294774e-01_rb,& - & 8.275904e-01_rb,8.257282e-01_rb,8.238893e-01_rb,8.220721e-01_rb,8.202751e-01_rb,& - & 8.184965e-01_rb,8.167346e-01_rb,8.1499e-01_rb /) + & 9.929711e-01_rb,9.896942e-01_rb,9.852408e-01_rb,9.806820e-01_rb,9.764512e-01_rb,& + & 9.725375e-01_rb,9.688677e-01_rb,9.653832e-01_rb,9.620552e-01_rb,9.588522e-01_rb,& + & 9.557475e-01_rb,9.527265e-01_rb,9.497731e-01_rb,9.468756e-01_rb,9.440270e-01_rb,& + & 9.412230e-01_rb,9.384592e-01_rb,9.357287e-01_rb,9.330369e-01_rb,9.303778e-01_rb,& + & 9.277502e-01_rb,9.251546e-01_rb,9.225907e-01_rb,9.200553e-01_rb,9.175521e-01_rb,& + & 9.150773e-01_rb,9.126352e-01_rb,9.102260e-01_rb,9.078485e-01_rb,9.055057e-01_rb,& + & 9.031978e-01_rb,9.009306e-01_rb,8.987010e-01_rb,8.965177e-01_rb,8.943774e-01_rb,& + & 8.922869e-01_rb,8.902430e-01_rb,8.882551e-01_rb,8.863182e-01_rb,8.844373e-01_rb,& + & 8.826143e-01_rb,8.808499e-01_rb,8.791413e-01_rb,8.774940e-01_rb,8.759019e-01_rb,& + & 8.743650e-01_rb,8.728941e-01_rb,8.714712e-01_rb,8.701065e-01_rb,8.688008e-01_rb,& + & 8.675409e-01_rb,8.663295e-01_rb,8.651714e-01_rb,8.640637e-01_rb,8.629943e-01_rb,& + & 8.619762e-01_rb,8.609995e-01_rb,8.600581e-01_rb /) +! BAND 19 ssaliq1(:, 19) = (/ & - & 9.999916e-01_rb,9.987396e-01_rb,9.966900e-01_rb,9.950738e-01_rb,9.937531e-01_rb,& - & 9.925912e-01_rb,9.914525e-01_rb,9.902018e-01_rb,9.887046e-01_rb,9.868263e-01_rb,& - & 9.849039e-01_rb,9.832372e-01_rb,9.815265e-01_rb,9.797770e-01_rb,9.779940e-01_rb,& - & 9.761827e-01_rb,9.743481e-01_rb,9.724955e-01_rb,9.706303e-01_rb,9.687575e-01_rb,& - & 9.668823e-01_rb,9.650100e-01_rb,9.631457e-01_rb,9.612947e-01_rb,9.594622e-01_rb,& - & 9.576534e-01_rb,9.558734e-01_rb,9.541275e-01_rb,9.522059e-01_rb,9.504258e-01_rb,& - & 9.486459e-01_rb,9.468676e-01_rb,9.450921e-01_rb,9.433208e-01_rb,9.415548e-01_rb,& - & 9.397955e-01_rb,9.380441e-01_rb,9.363022e-01_rb,9.345706e-01_rb,9.328510e-01_rb,& - & 9.311445e-01_rb,9.294524e-01_rb,9.277761e-01_rb,9.261167e-01_rb,9.244755e-01_rb,& - & 9.228540e-01_rb,9.212534e-01_rb,9.196748e-01_rb,9.181197e-01_rb,9.165894e-01_rb,& - & 9.150851e-01_rb,9.136080e-01_rb,9.121596e-01_rb,9.107410e-01_rb,9.093536e-01_rb,& - & 9.079987e-01_rb,9.066775e-01_rb,9.0539e-01_rb /) + & 9.910612e-01_rb,9.854226e-01_rb,9.795008e-01_rb,9.742920e-01_rb,9.695996e-01_rb,& + & 9.652274e-01_rb,9.610648e-01_rb,9.570521e-01_rb,9.531397e-01_rb,9.493086e-01_rb,& + & 9.455413e-01_rb,9.418362e-01_rb,9.381902e-01_rb,9.346016e-01_rb,9.310718e-01_rb,& + & 9.275957e-01_rb,9.241757e-01_rb,9.208038e-01_rb,9.174802e-01_rb,9.142058e-01_rb,& + & 9.109753e-01_rb,9.077895e-01_rb,9.046433e-01_rb,9.015409e-01_rb,8.984784e-01_rb,& + & 8.954572e-01_rb,8.924748e-01_rb,8.895367e-01_rb,8.866395e-01_rb,8.837864e-01_rb,& + & 8.809819e-01_rb,8.782267e-01_rb,8.755231e-01_rb,8.728712e-01_rb,8.702802e-01_rb,& + & 8.677443e-01_rb,8.652733e-01_rb,8.628678e-01_rb,8.605300e-01_rb,8.582593e-01_rb,& + & 8.560596e-01_rb,8.539352e-01_rb,8.518782e-01_rb,8.498915e-01_rb,8.479790e-01_rb,& + & 8.461384e-01_rb,8.443645e-01_rb,8.426613e-01_rb,8.410229e-01_rb,8.394495e-01_rb,& + & 8.379428e-01_rb,8.364967e-01_rb,8.351117e-01_rb,8.337820e-01_rb,8.325091e-01_rb,& + & 8.312874e-01_rb,8.301169e-01_rb,8.289985e-01_rb /) +! BAND 20 ssaliq1(:, 20) = (/ & - & 9.979493e-01_rb,9.964113e-01_rb,9.950014e-01_rb,9.937045e-01_rb,9.924964e-01_rb,& - & 9.913546e-01_rb,9.902575e-01_rb,9.891843e-01_rb,9.881136e-01_rb,9.870238e-01_rb,& - & 9.859934e-01_rb,9.849372e-01_rb,9.838873e-01_rb,9.828434e-01_rb,9.818052e-01_rb,& - & 9.807725e-01_rb,9.797450e-01_rb,9.787225e-01_rb,9.777047e-01_rb,9.766914e-01_rb,& - & 9.756823e-01_rb,9.746771e-01_rb,9.736756e-01_rb,9.726775e-01_rb,9.716827e-01_rb,& - & 9.706907e-01_rb,9.697014e-01_rb,9.687145e-01_rb,9.678060e-01_rb,9.668108e-01_rb,& - & 9.658218e-01_rb,9.648391e-01_rb,9.638629e-01_rb,9.628936e-01_rb,9.619313e-01_rb,& - & 9.609763e-01_rb,9.600287e-01_rb,9.590888e-01_rb,9.581569e-01_rb,9.572330e-01_rb,& - & 9.563176e-01_rb,9.554108e-01_rb,9.545128e-01_rb,9.536239e-01_rb,9.527443e-01_rb,& - & 9.518741e-01_rb,9.510137e-01_rb,9.501633e-01_rb,9.493230e-01_rb,9.484931e-01_rb,& - & 9.476740e-01_rb,9.468656e-01_rb,9.460683e-01_rb,9.452824e-01_rb,9.445080e-01_rb,& - & 9.437454e-01_rb,9.429948e-01_rb,9.4226e-01_rb /) + & 9.969802e-01_rb,9.950445e-01_rb,9.931448e-01_rb,9.914272e-01_rb,9.898652e-01_rb,& + & 9.884250e-01_rb,9.870637e-01_rb,9.857482e-01_rb,9.844558e-01_rb,9.831755e-01_rb,& + & 9.819068e-01_rb,9.806477e-01_rb,9.794000e-01_rb,9.781666e-01_rb,9.769461e-01_rb,& + & 9.757386e-01_rb,9.745459e-01_rb,9.733650e-01_rb,9.721953e-01_rb,9.710398e-01_rb,& + & 9.698936e-01_rb,9.687583e-01_rb,9.676334e-01_rb,9.665192e-01_rb,9.654132e-01_rb,& + & 9.643208e-01_rb,9.632374e-01_rb,9.621625e-01_rb,9.611003e-01_rb,9.600518e-01_rb,& + & 9.590144e-01_rb,9.579922e-01_rb,9.569864e-01_rb,9.559948e-01_rb,9.550239e-01_rb,& + & 9.540698e-01_rb,9.531382e-01_rb,9.522280e-01_rb,9.513409e-01_rb,9.504772e-01_rb,& + & 9.496360e-01_rb,9.488220e-01_rb,9.480327e-01_rb,9.472693e-01_rb,9.465333e-01_rb,& + & 9.458211e-01_rb,9.451344e-01_rb,9.444732e-01_rb,9.438372e-01_rb,9.432268e-01_rb,& + & 9.426391e-01_rb,9.420757e-01_rb,9.415308e-01_rb,9.410102e-01_rb,9.405115e-01_rb,& + & 9.400326e-01_rb,9.395716e-01_rb,9.391313e-01_rb /) +! BAND 21 ssaliq1(:, 21) = (/ & - & 9.988742e-01_rb,9.982668e-01_rb,9.976935e-01_rb,9.971497e-01_rb,9.966314e-01_rb,& - & 9.961344e-01_rb,9.956545e-01_rb,9.951873e-01_rb,9.947286e-01_rb,9.942741e-01_rb,& - & 9.938457e-01_rb,9.933947e-01_rb,9.929473e-01_rb,9.925032e-01_rb,9.920621e-01_rb,& - & 9.916237e-01_rb,9.911875e-01_rb,9.907534e-01_rb,9.903209e-01_rb,9.898898e-01_rb,& - & 9.894597e-01_rb,9.890304e-01_rb,9.886015e-01_rb,9.881726e-01_rb,9.877435e-01_rb,& - & 9.873138e-01_rb,9.868833e-01_rb,9.864516e-01_rb,9.860698e-01_rb,9.856317e-01_rb,& - & 9.851957e-01_rb,9.847618e-01_rb,9.843302e-01_rb,9.839008e-01_rb,9.834739e-01_rb,& - & 9.830494e-01_rb,9.826275e-01_rb,9.822083e-01_rb,9.817918e-01_rb,9.813782e-01_rb,& - & 9.809675e-01_rb,9.805598e-01_rb,9.801552e-01_rb,9.797538e-01_rb,9.793556e-01_rb,& - & 9.789608e-01_rb,9.785695e-01_rb,9.781817e-01_rb,9.777975e-01_rb,9.774171e-01_rb,& - & 9.770404e-01_rb,9.766676e-01_rb,9.762988e-01_rb,9.759340e-01_rb,9.755733e-01_rb,& - & 9.752169e-01_rb,9.748649e-01_rb,9.7452e-01_rb /) + & 9.980034e-01_rb,9.968572e-01_rb,9.958696e-01_rb,9.949747e-01_rb,9.941241e-01_rb,& + & 9.933043e-01_rb,9.924971e-01_rb,9.916978e-01_rb,9.909023e-01_rb,9.901046e-01_rb,& + & 9.893087e-01_rb,9.885146e-01_rb,9.877195e-01_rb,9.869283e-01_rb,9.861379e-01_rb,& + & 9.853523e-01_rb,9.845715e-01_rb,9.837945e-01_rb,9.830217e-01_rb,9.822567e-01_rb,& + & 9.814935e-01_rb,9.807356e-01_rb,9.799815e-01_rb,9.792332e-01_rb,9.784845e-01_rb,& + & 9.777424e-01_rb,9.770042e-01_rb,9.762695e-01_rb,9.755416e-01_rb,9.748152e-01_rb,& + & 9.740974e-01_rb,9.733873e-01_rb,9.726813e-01_rb,9.719861e-01_rb,9.713010e-01_rb,& + & 9.706262e-01_rb,9.699647e-01_rb,9.693144e-01_rb,9.686794e-01_rb,9.680596e-01_rb,& + & 9.674540e-01_rb,9.668657e-01_rb,9.662926e-01_rb,9.657390e-01_rb,9.652019e-01_rb,& + & 9.646820e-01_rb,9.641784e-01_rb,9.636945e-01_rb,9.632260e-01_rb,9.627743e-01_rb,& + & 9.623418e-01_rb,9.619227e-01_rb,9.615194e-01_rb,9.611341e-01_rb,9.607629e-01_rb,& + & 9.604057e-01_rb,9.600622e-01_rb,9.597322e-01_rb /) +! BAND 22 ssaliq1(:, 22) = (/ & - & 9.994441e-01_rb,9.991608e-01_rb,9.988949e-01_rb,9.986439e-01_rb,9.984054e-01_rb,& - & 9.981768e-01_rb,9.979557e-01_rb,9.977396e-01_rb,9.975258e-01_rb,9.973120e-01_rb,& - & 9.971011e-01_rb,9.968852e-01_rb,9.966708e-01_rb,9.964578e-01_rb,9.962462e-01_rb,& - & 9.960357e-01_rb,9.958264e-01_rb,9.956181e-01_rb,9.954108e-01_rb,9.952043e-01_rb,& - & 9.949987e-01_rb,9.947937e-01_rb,9.945892e-01_rb,9.943853e-01_rb,9.941818e-01_rb,& - & 9.939786e-01_rb,9.937757e-01_rb,9.935728e-01_rb,9.933922e-01_rb,9.931825e-01_rb,& - & 9.929739e-01_rb,9.927661e-01_rb,9.925592e-01_rb,9.923534e-01_rb,9.921485e-01_rb,& - & 9.919447e-01_rb,9.917421e-01_rb,9.915406e-01_rb,9.913403e-01_rb,9.911412e-01_rb,& - & 9.909435e-01_rb,9.907470e-01_rb,9.905519e-01_rb,9.903581e-01_rb,9.901659e-01_rb,& - & 9.899751e-01_rb,9.897858e-01_rb,9.895981e-01_rb,9.894120e-01_rb,9.892276e-01_rb,& - & 9.890447e-01_rb,9.888637e-01_rb,9.886845e-01_rb,9.885070e-01_rb,9.883314e-01_rb,& - & 9.881576e-01_rb,9.879859e-01_rb,9.8782e-01_rb /) + & 9.988219e-01_rb,9.981767e-01_rb,9.976168e-01_rb,9.971066e-01_rb,9.966195e-01_rb,& + & 9.961566e-01_rb,9.956995e-01_rb,9.952481e-01_rb,9.947982e-01_rb,9.943495e-01_rb,& + & 9.938955e-01_rb,9.934368e-01_rb,9.929825e-01_rb,9.925239e-01_rb,9.920653e-01_rb,& + & 9.916096e-01_rb,9.911552e-01_rb,9.907067e-01_rb,9.902594e-01_rb,9.898178e-01_rb,& + & 9.893791e-01_rb,9.889453e-01_rb,9.885122e-01_rb,9.880837e-01_rb,9.876567e-01_rb,& + & 9.872331e-01_rb,9.868121e-01_rb,9.863938e-01_rb,9.859790e-01_rb,9.855650e-01_rb,& + & 9.851548e-01_rb,9.847491e-01_rb,9.843496e-01_rb,9.839521e-01_rb,9.835606e-01_rb,& + & 9.831771e-01_rb,9.827975e-01_rb,9.824292e-01_rb,9.820653e-01_rb,9.817124e-01_rb,& + & 9.813644e-01_rb,9.810291e-01_rb,9.807020e-01_rb,9.803864e-01_rb,9.800782e-01_rb,& + & 9.797821e-01_rb,9.794958e-01_rb,9.792179e-01_rb,9.789509e-01_rb,9.786940e-01_rb,& + & 9.784460e-01_rb,9.782090e-01_rb,9.779789e-01_rb,9.777553e-01_rb,9.775425e-01_rb,& + & 9.773387e-01_rb,9.771420e-01_rb,9.769529e-01_rb /) +! BAND 23 ssaliq1(:, 23) = (/ & - & 9.999138e-01_rb,9.998730e-01_rb,9.998338e-01_rb,9.997965e-01_rb,9.997609e-01_rb,& - & 9.997270e-01_rb,9.996944e-01_rb,9.996629e-01_rb,9.996321e-01_rb,9.996016e-01_rb,& - & 9.995690e-01_rb,9.995372e-01_rb,9.995057e-01_rb,9.994744e-01_rb,9.994433e-01_rb,& - & 9.994124e-01_rb,9.993817e-01_rb,9.993510e-01_rb,9.993206e-01_rb,9.992903e-01_rb,& - & 9.992600e-01_rb,9.992299e-01_rb,9.991998e-01_rb,9.991698e-01_rb,9.991398e-01_rb,& - & 9.991098e-01_rb,9.990799e-01_rb,9.990499e-01_rb,9.990231e-01_rb,9.989920e-01_rb,& - & 9.989611e-01_rb,9.989302e-01_rb,9.988996e-01_rb,9.988690e-01_rb,9.988386e-01_rb,& - & 9.988084e-01_rb,9.987783e-01_rb,9.987485e-01_rb,9.987187e-01_rb,9.986891e-01_rb,& - & 9.986598e-01_rb,9.986306e-01_rb,9.986017e-01_rb,9.985729e-01_rb,9.985443e-01_rb,& - & 9.985160e-01_rb,9.984879e-01_rb,9.984600e-01_rb,9.984324e-01_rb,9.984050e-01_rb,& - & 9.983778e-01_rb,9.983509e-01_rb,9.983243e-01_rb,9.982980e-01_rb,9.982719e-01_rb,& - & 9.982461e-01_rb,9.982206e-01_rb,9.9820e-01_rb /) + & 9.998902e-01_rb,9.998395e-01_rb,9.997915e-01_rb,9.997442e-01_rb,9.997016e-01_rb,& + & 9.996600e-01_rb,9.996200e-01_rb,9.995806e-01_rb,9.995411e-01_rb,9.995005e-01_rb,& + & 9.994589e-01_rb,9.994178e-01_rb,9.993766e-01_rb,9.993359e-01_rb,9.992948e-01_rb,& + & 9.992533e-01_rb,9.992120e-01_rb,9.991723e-01_rb,9.991313e-01_rb,9.990906e-01_rb,& + & 9.990510e-01_rb,9.990113e-01_rb,9.989716e-01_rb,9.989323e-01_rb,9.988923e-01_rb,& + & 9.988532e-01_rb,9.988140e-01_rb,9.987761e-01_rb,9.987373e-01_rb,9.986989e-01_rb,& + & 9.986597e-01_rb,9.986239e-01_rb,9.985861e-01_rb,9.985485e-01_rb,9.985123e-01_rb,& + & 9.984762e-01_rb,9.984415e-01_rb,9.984065e-01_rb,9.983722e-01_rb,9.983398e-01_rb,& + & 9.983078e-01_rb,9.982758e-01_rb,9.982461e-01_rb,9.982157e-01_rb,9.981872e-01_rb,& + & 9.981595e-01_rb,9.981324e-01_rb,9.981068e-01_rb,9.980811e-01_rb,9.980580e-01_rb,& + & 9.980344e-01_rb,9.980111e-01_rb,9.979908e-01_rb,9.979690e-01_rb,9.979492e-01_rb,& + & 9.979316e-01_rb,9.979116e-01_rb,9.978948e-01_rb /) +! BAND 24 ssaliq1(:, 24) = (/ & - & 9.999985e-01_rb,9.999979e-01_rb,9.999972e-01_rb,9.999966e-01_rb,9.999961e-01_rb,& - & 9.999955e-01_rb,9.999950e-01_rb,9.999944e-01_rb,9.999938e-01_rb,9.999933e-01_rb,& - & 9.999927e-01_rb,9.999921e-01_rb,9.999915e-01_rb,9.999910e-01_rb,9.999904e-01_rb,& - & 9.999899e-01_rb,9.999893e-01_rb,9.999888e-01_rb,9.999882e-01_rb,9.999877e-01_rb,& - & 9.999871e-01_rb,9.999866e-01_rb,9.999861e-01_rb,9.999855e-01_rb,9.999850e-01_rb,& - & 9.999844e-01_rb,9.999839e-01_rb,9.999833e-01_rb,9.999828e-01_rb,9.999823e-01_rb,& - & 9.999817e-01_rb,9.999812e-01_rb,9.999807e-01_rb,9.999801e-01_rb,9.999796e-01_rb,& - & 9.999791e-01_rb,9.999786e-01_rb,9.999781e-01_rb,9.999776e-01_rb,9.999770e-01_rb,& - & 9.999765e-01_rb,9.999761e-01_rb,9.999756e-01_rb,9.999751e-01_rb,9.999746e-01_rb,& - & 9.999741e-01_rb,9.999736e-01_rb,9.999732e-01_rb,9.999727e-01_rb,9.999722e-01_rb,& - & 9.999718e-01_rb,9.999713e-01_rb,9.999709e-01_rb,9.999705e-01_rb,9.999701e-01_rb,& - & 9.999697e-01_rb,9.999692e-01_rb,9.9997e-01_rb /) + & 9.999978e-01_rb,9.999948e-01_rb,9.999915e-01_rb,9.999905e-01_rb,9.999896e-01_rb,& + & 9.999887e-01_rb,9.999888e-01_rb,9.999888e-01_rb,9.999870e-01_rb,9.999854e-01_rb,& + & 9.999855e-01_rb,9.999856e-01_rb,9.999839e-01_rb,9.999834e-01_rb,9.999829e-01_rb,& + & 9.999809e-01_rb,9.999816e-01_rb,9.999793e-01_rb,9.999782e-01_rb,9.999779e-01_rb,& + & 9.999772e-01_rb,9.999764e-01_rb,9.999756e-01_rb,9.999744e-01_rb,9.999744e-01_rb,& + & 9.999736e-01_rb,9.999729e-01_rb,9.999716e-01_rb,9.999706e-01_rb,9.999692e-01_rb,& + & 9.999690e-01_rb,9.999675e-01_rb,9.999673e-01_rb,9.999660e-01_rb,9.999654e-01_rb,& + & 9.999647e-01_rb,9.999647e-01_rb,9.999625e-01_rb,9.999620e-01_rb,9.999614e-01_rb,& + & 9.999613e-01_rb,9.999607e-01_rb,9.999604e-01_rb,9.999594e-01_rb,9.999589e-01_rb,& + & 9.999586e-01_rb,9.999567e-01_rb,9.999550e-01_rb,9.999557e-01_rb,9.999542e-01_rb,& + & 9.999546e-01_rb,9.999539e-01_rb,9.999536e-01_rb,9.999526e-01_rb,9.999523e-01_rb,& + & 9.999508e-01_rb,9.999534e-01_rb,9.999507e-01_rb /) +! BAND 25 ssaliq1(:, 25) = (/ & - & 9.999999e-01_rb,9.999998e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,& - & 9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,9.999995e-01_rb,9.999994e-01_rb,& - & 9.999994e-01_rb,9.999993e-01_rb,9.999993e-01_rb,9.999992e-01_rb,9.999992e-01_rb,& - & 9.999991e-01_rb,9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,& - & 9.999989e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,9.999987e-01_rb,& - & 9.999987e-01_rb,9.999986e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999985e-01_rb,& - & 9.999984e-01_rb,9.999984e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999983e-01_rb,& - & 9.999982e-01_rb,9.999982e-01_rb,9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,& - & 9.999980e-01_rb,9.999980e-01_rb,9.999979e-01_rb,9.999979e-01_rb,9.999978e-01_rb,& - & 9.999978e-01_rb,9.999977e-01_rb,9.999977e-01_rb,9.999977e-01_rb,9.999976e-01_rb,& - & 9.999976e-01_rb,9.999975e-01_rb,9.999975e-01_rb,9.999974e-01_rb,9.999974e-01_rb,& - & 9.999974e-01_rb,9.999973e-01_rb,1.0000e+00_rb /) + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999995e-01_rb,& + & 9.999995e-01_rb,9.999990e-01_rb,9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,& + & 9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,9.999986e-01_rb,9.999988e-01_rb,& + & 9.999986e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999985e-01_rb,& + & 9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999983e-01_rb,9.999981e-01_rb,& + & 9.999981e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999984e-01_rb,& + & 9.999982e-01_rb,9.999983e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999981e-01_rb,& + & 9.999978e-01_rb,9.999979e-01_rb,9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,& + & 9.999983e-01_rb,9.999983e-01_rb,9.999983e-01_rb /) +! BAND 26 ssaliq1(:, 26) = (/ & - & 9.999997e-01_rb,9.999995e-01_rb,9.999993e-01_rb,9.999992e-01_rb,9.999990e-01_rb,& - & 9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999985e-01_rb,& - & 9.999984e-01_rb,9.999983e-01_rb,9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,& - & 9.999978e-01_rb,9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,9.999974e-01_rb,& - & 9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999968e-01_rb,& - & 9.999967e-01_rb,9.999966e-01_rb,9.999965e-01_rb,9.999964e-01_rb,9.999963e-01_rb,& - & 9.999962e-01_rb,9.999961e-01_rb,9.999959e-01_rb,9.999958e-01_rb,9.999957e-01_rb,& - & 9.999956e-01_rb,9.999955e-01_rb,9.999954e-01_rb,9.999953e-01_rb,9.999952e-01_rb,& - & 9.999951e-01_rb,9.999949e-01_rb,9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,& - & 9.999945e-01_rb,9.999944e-01_rb,9.999943e-01_rb,9.999942e-01_rb,9.999941e-01_rb,& - & 9.999940e-01_rb,9.999939e-01_rb,9.999938e-01_rb,9.999937e-01_rb,9.999936e-01_rb,& - & 9.999935e-01_rb,9.999934e-01_rb,9.9999e-01_rb /) + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999991e-01_rb,& + & 9.999990e-01_rb,9.999992e-01_rb,9.999995e-01_rb,9.999986e-01_rb,9.999994e-01_rb,& + & 9.999985e-01_rb,9.999980e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999979e-01_rb,& + & 9.999969e-01_rb,9.999977e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999969e-01_rb,& + & 9.999965e-01_rb,9.999970e-01_rb,9.999985e-01_rb,9.999973e-01_rb,9.999961e-01_rb,& + & 9.999968e-01_rb,9.999952e-01_rb,9.999970e-01_rb,9.999974e-01_rb,9.999965e-01_rb,& + & 9.999969e-01_rb,9.999970e-01_rb,9.999970e-01_rb,9.999960e-01_rb,9.999923e-01_rb,& + & 9.999958e-01_rb,9.999937e-01_rb,9.999960e-01_rb,9.999953e-01_rb,9.999946e-01_rb,& + & 9.999946e-01_rb,9.999957e-01_rb,9.999951e-01_rb /) +! BAND 27 ssaliq1(:, 27) = (/ & - & 9.999984e-01_rb,9.999976e-01_rb,9.999969e-01_rb,9.999962e-01_rb,9.999956e-01_rb,& - & 9.999950e-01_rb,9.999945e-01_rb,9.999940e-01_rb,9.999935e-01_rb,9.999931e-01_rb,& - & 9.999926e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb,9.999903e-01_rb,& - & 9.999897e-01_rb,9.999891e-01_rb,9.999886e-01_rb,9.999880e-01_rb,9.999874e-01_rb,& - & 9.999868e-01_rb,9.999863e-01_rb,9.999857e-01_rb,9.999851e-01_rb,9.999846e-01_rb,& - & 9.999840e-01_rb,9.999835e-01_rb,9.999829e-01_rb,9.999824e-01_rb,9.999818e-01_rb,& - & 9.999812e-01_rb,9.999806e-01_rb,9.999800e-01_rb,9.999795e-01_rb,9.999789e-01_rb,& - & 9.999783e-01_rb,9.999778e-01_rb,9.999773e-01_rb,9.999767e-01_rb,9.999761e-01_rb,& - & 9.999756e-01_rb,9.999750e-01_rb,9.999745e-01_rb,9.999739e-01_rb,9.999734e-01_rb,& - & 9.999729e-01_rb,9.999723e-01_rb,9.999718e-01_rb,9.999713e-01_rb,9.999708e-01_rb,& - & 9.999703e-01_rb,9.999697e-01_rb,9.999692e-01_rb,9.999687e-01_rb,9.999683e-01_rb,& - & 9.999678e-01_rb,9.999673e-01_rb,9.9997e-01_rb /) + & 1.000000e+00_rb,1.000000e+00_rb,9.999983e-01_rb,9.999979e-01_rb,9.999965e-01_rb,& + & 9.999949e-01_rb,9.999948e-01_rb,9.999918e-01_rb,9.999917e-01_rb,9.999923e-01_rb,& + & 9.999908e-01_rb,9.999889e-01_rb,9.999902e-01_rb,9.999895e-01_rb,9.999881e-01_rb,& + & 9.999882e-01_rb,9.999876e-01_rb,9.999866e-01_rb,9.999866e-01_rb,9.999858e-01_rb,& + & 9.999860e-01_rb,9.999852e-01_rb,9.999836e-01_rb,9.999831e-01_rb,9.999818e-01_rb,& + & 9.999808e-01_rb,9.999816e-01_rb,9.999800e-01_rb,9.999783e-01_rb,9.999780e-01_rb,& + & 9.999763e-01_rb,9.999746e-01_rb,9.999731e-01_rb,9.999713e-01_rb,9.999762e-01_rb,& + & 9.999740e-01_rb,9.999670e-01_rb,9.999703e-01_rb,9.999687e-01_rb,9.999666e-01_rb,& + & 9.999683e-01_rb,9.999667e-01_rb,9.999611e-01_rb,9.999635e-01_rb,9.999600e-01_rb,& + & 9.999635e-01_rb,9.999594e-01_rb,9.999601e-01_rb,9.999586e-01_rb,9.999559e-01_rb,& + & 9.999569e-01_rb,9.999558e-01_rb,9.999523e-01_rb,9.999535e-01_rb,9.999529e-01_rb,& + & 9.999553e-01_rb,9.999495e-01_rb,9.999490e-01_rb /) +! BAND 28 ssaliq1(:, 28) = (/ & - & 9.999981e-01_rb,9.999973e-01_rb,9.999965e-01_rb,9.999958e-01_rb,9.999951e-01_rb,& - & 9.999943e-01_rb,9.999937e-01_rb,9.999930e-01_rb,9.999924e-01_rb,9.999918e-01_rb,& - & 9.999912e-01_rb,9.999905e-01_rb,9.999897e-01_rb,9.999890e-01_rb,9.999883e-01_rb,& - & 9.999876e-01_rb,9.999869e-01_rb,9.999862e-01_rb,9.999855e-01_rb,9.999847e-01_rb,& - & 9.999840e-01_rb,9.999834e-01_rb,9.999827e-01_rb,9.999819e-01_rb,9.999812e-01_rb,& - & 9.999805e-01_rb,9.999799e-01_rb,9.999791e-01_rb,9.999785e-01_rb,9.999778e-01_rb,& - & 9.999771e-01_rb,9.999764e-01_rb,9.999757e-01_rb,9.999750e-01_rb,9.999743e-01_rb,& - & 9.999736e-01_rb,9.999729e-01_rb,9.999722e-01_rb,9.999715e-01_rb,9.999709e-01_rb,& - & 9.999701e-01_rb,9.999695e-01_rb,9.999688e-01_rb,9.999682e-01_rb,9.999675e-01_rb,& - & 9.999669e-01_rb,9.999662e-01_rb,9.999655e-01_rb,9.999649e-01_rb,9.999642e-01_rb,& - & 9.999636e-01_rb,9.999630e-01_rb,9.999624e-01_rb,9.999618e-01_rb,9.999612e-01_rb,& - & 9.999606e-01_rb,9.999600e-01_rb,9.9996e-01_rb /) + & 9.999920e-01_rb,9.999873e-01_rb,9.999855e-01_rb,9.999832e-01_rb,9.999807e-01_rb,& + & 9.999778e-01_rb,9.999754e-01_rb,9.999721e-01_rb,9.999692e-01_rb,9.999651e-01_rb,& + & 9.999621e-01_rb,9.999607e-01_rb,9.999567e-01_rb,9.999546e-01_rb,9.999521e-01_rb,& + & 9.999491e-01_rb,9.999457e-01_rb,9.999439e-01_rb,9.999403e-01_rb,9.999374e-01_rb,& + & 9.999353e-01_rb,9.999315e-01_rb,9.999282e-01_rb,9.999244e-01_rb,9.999234e-01_rb,& + & 9.999189e-01_rb,9.999130e-01_rb,9.999117e-01_rb,9.999073e-01_rb,9.999020e-01_rb,& + & 9.998993e-01_rb,9.998987e-01_rb,9.998922e-01_rb,9.998893e-01_rb,9.998869e-01_rb,& + & 9.998805e-01_rb,9.998778e-01_rb,9.998751e-01_rb,9.998708e-01_rb,9.998676e-01_rb,& + & 9.998624e-01_rb,9.998642e-01_rb,9.998582e-01_rb,9.998547e-01_rb,9.998546e-01_rb,& + & 9.998477e-01_rb,9.998487e-01_rb,9.998466e-01_rb,9.998403e-01_rb,9.998412e-01_rb,& + & 9.998406e-01_rb,9.998342e-01_rb,9.998326e-01_rb,9.998333e-01_rb,9.998328e-01_rb,& + & 9.998290e-01_rb,9.998276e-01_rb,9.998249e-01_rb /) +! BAND 29 ssaliq1(:, 29) = (/ & - & 8.505737e-01_rb,8.465102e-01_rb,8.394829e-01_rb,8.279508e-01_rb,8.110806e-01_rb,& - & 7.900397e-01_rb,7.669615e-01_rb,7.444422e-01_rb,7.253055e-01_rb,7.124831e-01_rb,& - & 7.016434e-01_rb,6.885485e-01_rb,6.767340e-01_rb,6.661029e-01_rb,6.565577e-01_rb,& - & 6.480013e-01_rb,6.403373e-01_rb,6.334697e-01_rb,6.273034e-01_rb,6.217440e-01_rb,& - & 6.166983e-01_rb,6.120740e-01_rb,6.077796e-01_rb,6.037249e-01_rb,5.998207e-01_rb,& - & 5.959788e-01_rb,5.921123e-01_rb,5.881354e-01_rb,5.891285e-01_rb,5.851143e-01_rb,& - & 5.814653e-01_rb,5.781606e-01_rb,5.751792e-01_rb,5.724998e-01_rb,5.701016e-01_rb,& - & 5.679634e-01_rb,5.660642e-01_rb,5.643829e-01_rb,5.628984e-01_rb,5.615898e-01_rb,& - & 5.604359e-01_rb,5.594158e-01_rb,5.585083e-01_rb,5.576924e-01_rb,5.569470e-01_rb,& - & 5.562512e-01_rb,5.555838e-01_rb,5.549239e-01_rb,5.542503e-01_rb,5.535420e-01_rb,& - & 5.527781e-01_rb,5.519374e-01_rb,5.509989e-01_rb,5.499417e-01_rb,5.487445e-01_rb,& - & 5.473865e-01_rb,5.458466e-01_rb,5.4410e-01_rb /) - -! asymmetry parameter + & 8.383753e-01_rb,8.461471e-01_rb,8.373325e-01_rb,8.212889e-01_rb,8.023834e-01_rb,& + & 7.829501e-01_rb,7.641777e-01_rb,7.466000e-01_rb,7.304023e-01_rb,7.155998e-01_rb,& + & 7.021259e-01_rb,6.898840e-01_rb,6.787615e-01_rb,6.686479e-01_rb,6.594414e-01_rb,& + & 6.510417e-01_rb,6.433668e-01_rb,6.363335e-01_rb,6.298788e-01_rb,6.239398e-01_rb,& + & 6.184633e-01_rb,6.134055e-01_rb,6.087228e-01_rb,6.043786e-01_rb,6.003439e-01_rb,& + & 5.965910e-01_rb,5.930917e-01_rb,5.898280e-01_rb,5.867798e-01_rb,5.839264e-01_rb,& + & 5.812576e-01_rb,5.787592e-01_rb,5.764163e-01_rb,5.742189e-01_rb,5.721598e-01_rb,& + & 5.702286e-01_rb,5.684182e-01_rb,5.667176e-01_rb,5.651237e-01_rb,5.636253e-01_rb,& + & 5.622228e-01_rb,5.609074e-01_rb,5.596713e-01_rb,5.585089e-01_rb,5.574223e-01_rb,& + & 5.564002e-01_rb,5.554411e-01_rb,5.545397e-01_rb,5.536914e-01_rb,5.528967e-01_rb,& + & 5.521495e-01_rb,5.514457e-01_rb,5.507818e-01_rb,5.501623e-01_rb,5.495750e-01_rb,& + & 5.490192e-01_rb,5.484980e-01_rb,5.480046e-01_rb /) +! BAND 16 asyliq1(:, 16) = (/ & - & 8.133297e-01_rb,8.133528e-01_rb,8.173865e-01_rb,8.243205e-01_rb,8.333063e-01_rb,& - & 8.436317e-01_rb,8.546611e-01_rb,8.657934e-01_rb,8.764345e-01_rb,8.859837e-01_rb,& - & 8.627394e-01_rb,8.824569e-01_rb,8.976887e-01_rb,9.089541e-01_rb,9.167699e-01_rb,& - & 9.216517e-01_rb,9.241147e-01_rb,9.246743e-01_rb,9.238469e-01_rb,9.221504e-01_rb,& - & 9.201045e-01_rb,9.182299e-01_rb,9.170491e-01_rb,9.170862e-01_rb,9.188653e-01_rb,& - & 9.229111e-01_rb,9.297468e-01_rb,9.398950e-01_rb,9.203269e-01_rb,9.260693e-01_rb,& - & 9.309373e-01_rb,9.349918e-01_rb,9.382935e-01_rb,9.409030e-01_rb,9.428809e-01_rb,& - & 9.442881e-01_rb,9.451851e-01_rb,9.456331e-01_rb,9.456926e-01_rb,9.454247e-01_rb,& - & 9.448902e-01_rb,9.441503e-01_rb,9.432661e-01_rb,9.422987e-01_rb,9.413094e-01_rb,& - & 9.403594e-01_rb,9.395102e-01_rb,9.388230e-01_rb,9.383594e-01_rb,9.381810e-01_rb,& - & 9.383489e-01_rb,9.389251e-01_rb,9.399707e-01_rb,9.415475e-01_rb,9.437167e-01_rb,& - & 9.465399e-01_rb,9.500786e-01_rb,9.5439e-01_rb /) + & 8.038165e-01_rb,8.014154e-01_rb,7.942381e-01_rb,7.970521e-01_rb,8.086621e-01_rb,& + & 8.233392e-01_rb,8.374127e-01_rb,8.495742e-01_rb,8.596945e-01_rb,8.680497e-01_rb,& + & 8.750005e-01_rb,8.808589e-01_rb,8.858749e-01_rb,8.902403e-01_rb,8.940939e-01_rb,& + & 8.975379e-01_rb,9.006450e-01_rb,9.034741e-01_rb,9.060659e-01_rb,9.084561e-01_rb,& + & 9.106675e-01_rb,9.127198e-01_rb,9.146332e-01_rb,9.164194e-01_rb,9.180970e-01_rb,& + & 9.196658e-01_rb,9.211421e-01_rb,9.225352e-01_rb,9.238443e-01_rb,9.250841e-01_rb,& + & 9.262541e-01_rb,9.273620e-01_rb,9.284081e-01_rb,9.294002e-01_rb,9.303395e-01_rb,& + & 9.312285e-01_rb,9.320715e-01_rb,9.328716e-01_rb,9.336271e-01_rb,9.343427e-01_rb,& + & 9.350219e-01_rb,9.356647e-01_rb,9.362728e-01_rb,9.368495e-01_rb,9.373956e-01_rb,& + & 9.379113e-01_rb,9.383987e-01_rb,9.388608e-01_rb,9.392986e-01_rb,9.397132e-01_rb,& + & 9.401063e-01_rb,9.404776e-01_rb,9.408299e-01_rb,9.411641e-01_rb,9.414800e-01_rb,& + & 9.417787e-01_rb,9.420633e-01_rb,9.423364e-01_rb /) +! BAND 17 asyliq1(:, 17) = (/ & - & 8.794448e-01_rb,8.819306e-01_rb,8.837667e-01_rb,8.853832e-01_rb,8.871010e-01_rb,& - & 8.892675e-01_rb,8.922584e-01_rb,8.964666e-01_rb,9.022940e-01_rb,9.101456e-01_rb,& - & 8.839999e-01_rb,9.035610e-01_rb,9.184568e-01_rb,9.292315e-01_rb,9.364282e-01_rb,& - & 9.405887e-01_rb,9.422554e-01_rb,9.419703e-01_rb,9.402759e-01_rb,9.377159e-01_rb,& - & 9.348345e-01_rb,9.321769e-01_rb,9.302888e-01_rb,9.297166e-01_rb,9.310075e-01_rb,& - & 9.347080e-01_rb,9.413643e-01_rb,9.515216e-01_rb,9.306286e-01_rb,9.361781e-01_rb,& - & 9.408374e-01_rb,9.446692e-01_rb,9.477363e-01_rb,9.501013e-01_rb,9.518268e-01_rb,& - & 9.529756e-01_rb,9.536105e-01_rb,9.537938e-01_rb,9.535886e-01_rb,9.530574e-01_rb,& - & 9.522633e-01_rb,9.512688e-01_rb,9.501370e-01_rb,9.489306e-01_rb,9.477126e-01_rb,& - & 9.465459e-01_rb,9.454934e-01_rb,9.446183e-01_rb,9.439833e-01_rb,9.436519e-01_rb,& - & 9.436866e-01_rb,9.441508e-01_rb,9.451073e-01_rb,9.466195e-01_rb,9.487501e-01_rb,& - & 9.515621e-01_rb,9.551185e-01_rb,9.5948e-01_rb /) + & 8.941000e-01_rb,9.054049e-01_rb,9.049510e-01_rb,9.027216e-01_rb,9.021636e-01_rb,& + & 9.037878e-01_rb,9.069852e-01_rb,9.109817e-01_rb,9.152013e-01_rb,9.193040e-01_rb,& + & 9.231177e-01_rb,9.265712e-01_rb,9.296606e-01_rb,9.324048e-01_rb,9.348419e-01_rb,& + & 9.370131e-01_rb,9.389529e-01_rb,9.406954e-01_rb,9.422727e-01_rb,9.437088e-01_rb,& + & 9.450221e-01_rb,9.462308e-01_rb,9.473488e-01_rb,9.483830e-01_rb,9.493492e-01_rb,& + & 9.502541e-01_rb,9.510999e-01_rb,9.518971e-01_rb,9.526455e-01_rb,9.533554e-01_rb,& + & 9.540249e-01_rb,9.546571e-01_rb,9.552551e-01_rb,9.558258e-01_rb,9.563603e-01_rb,& + & 9.568713e-01_rb,9.573569e-01_rb,9.578141e-01_rb,9.582485e-01_rb,9.586604e-01_rb,& + & 9.590525e-01_rb,9.594218e-01_rb,9.597710e-01_rb,9.601052e-01_rb,9.604181e-01_rb,& + & 9.607159e-01_rb,9.609979e-01_rb,9.612655e-01_rb,9.615184e-01_rb,9.617564e-01_rb,& + & 9.619860e-01_rb,9.622009e-01_rb,9.624031e-01_rb,9.625957e-01_rb,9.627792e-01_rb,& + & 9.629530e-01_rb,9.631171e-01_rb,9.632746e-01_rb /) +! BAND 18 asyliq1(:, 18) = (/ & - & 8.478817e-01_rb,8.269312e-01_rb,8.161352e-01_rb,8.135960e-01_rb,8.173586e-01_rb,& - & 8.254167e-01_rb,8.357072e-01_rb,8.461167e-01_rb,8.544952e-01_rb,8.586776e-01_rb,& - & 8.335562e-01_rb,8.524273e-01_rb,8.669052e-01_rb,8.775014e-01_rb,8.847277e-01_rb,& - & 8.890958e-01_rb,8.911173e-01_rb,8.913038e-01_rb,8.901669e-01_rb,8.882182e-01_rb,& - & 8.859692e-01_rb,8.839315e-01_rb,8.826164e-01_rb,8.825356e-01_rb,8.842004e-01_rb,& - & 8.881223e-01_rb,8.948131e-01_rb,9.047837e-01_rb,8.855951e-01_rb,8.911796e-01_rb,& - & 8.959229e-01_rb,8.998837e-01_rb,9.031209e-01_rb,9.056939e-01_rb,9.076609e-01_rb,& - & 9.090812e-01_rb,9.100134e-01_rb,9.105167e-01_rb,9.106496e-01_rb,9.104712e-01_rb,& - & 9.100404e-01_rb,9.094159e-01_rb,9.086568e-01_rb,9.078218e-01_rb,9.069697e-01_rb,& - & 9.061595e-01_rb,9.054499e-01_rb,9.048999e-01_rb,9.045683e-01_rb,9.045142e-01_rb,& - & 9.047962e-01_rb,9.054730e-01_rb,9.066037e-01_rb,9.082472e-01_rb,9.104623e-01_rb,& - & 9.133079e-01_rb,9.168427e-01_rb,9.2113e-01_rb /) + & 8.574638e-01_rb,8.351383e-01_rb,8.142977e-01_rb,8.083068e-01_rb,8.129284e-01_rb,& + & 8.215827e-01_rb,8.307238e-01_rb,8.389963e-01_rb,8.460481e-01_rb,8.519273e-01_rb,& + & 8.568153e-01_rb,8.609116e-01_rb,8.643892e-01_rb,8.673941e-01_rb,8.700248e-01_rb,& + & 8.723707e-01_rb,8.744902e-01_rb,8.764240e-01_rb,8.782057e-01_rb,8.798593e-01_rb,& + & 8.814063e-01_rb,8.828573e-01_rb,8.842261e-01_rb,8.855196e-01_rb,8.867497e-01_rb,& + & 8.879164e-01_rb,8.890316e-01_rb,8.900941e-01_rb,8.911118e-01_rb,8.920832e-01_rb,& + & 8.930156e-01_rb,8.939091e-01_rb,8.947663e-01_rb,8.955888e-01_rb,8.963786e-01_rb,& + & 8.971350e-01_rb,8.978617e-01_rb,8.985590e-01_rb,8.992243e-01_rb,8.998631e-01_rb,& + & 9.004753e-01_rb,9.010602e-01_rb,9.016192e-01_rb,9.021542e-01_rb,9.026644e-01_rb,& + & 9.031535e-01_rb,9.036194e-01_rb,9.040656e-01_rb,9.044894e-01_rb,9.048933e-01_rb,& + & 9.052789e-01_rb,9.056481e-01_rb,9.060004e-01_rb,9.063343e-01_rb,9.066544e-01_rb,& + & 9.069604e-01_rb,9.072512e-01_rb,9.075290e-01_rb /) +! BAND 19 asyliq1(:, 19) = (/ & - & 8.216697e-01_rb,7.982871e-01_rb,7.891147e-01_rb,7.909083e-01_rb,8.003833e-01_rb,& - & 8.142516e-01_rb,8.292290e-01_rb,8.420356e-01_rb,8.493945e-01_rb,8.480316e-01_rb,& - & 8.212381e-01_rb,8.394984e-01_rb,8.534095e-01_rb,8.634813e-01_rb,8.702242e-01_rb,& - & 8.741483e-01_rb,8.757638e-01_rb,8.755808e-01_rb,8.741095e-01_rb,8.718604e-01_rb,& - & 8.693433e-01_rb,8.670686e-01_rb,8.655464e-01_rb,8.652872e-01_rb,8.668006e-01_rb,& - & 8.705973e-01_rb,8.771874e-01_rb,8.870809e-01_rb,8.678284e-01_rb,8.732315e-01_rb,& - & 8.778084e-01_rb,8.816166e-01_rb,8.847146e-01_rb,8.871603e-01_rb,8.890116e-01_rb,& - & 8.903266e-01_rb,8.911632e-01_rb,8.915796e-01_rb,8.916337e-01_rb,8.913834e-01_rb,& - & 8.908869e-01_rb,8.902022e-01_rb,8.893873e-01_rb,8.885001e-01_rb,8.875986e-01_rb,& - & 8.867411e-01_rb,8.859852e-01_rb,8.853891e-01_rb,8.850111e-01_rb,8.849089e-01_rb,& - & 8.851405e-01_rb,8.857639e-01_rb,8.868372e-01_rb,8.884185e-01_rb,8.905656e-01_rb,& - & 8.933368e-01_rb,8.967899e-01_rb,9.0098e-01_rb /) + & 8.349569e-01_rb,8.034579e-01_rb,7.932136e-01_rb,8.010156e-01_rb,8.137083e-01_rb,& + & 8.255339e-01_rb,8.351938e-01_rb,8.428286e-01_rb,8.488944e-01_rb,8.538187e-01_rb,& + & 8.579255e-01_rb,8.614473e-01_rb,8.645338e-01_rb,8.672908e-01_rb,8.697947e-01_rb,& + & 8.720843e-01_rb,8.742015e-01_rb,8.761718e-01_rb,8.780160e-01_rb,8.797479e-01_rb,& + & 8.813810e-01_rb,8.829250e-01_rb,8.843907e-01_rb,8.857822e-01_rb,8.871059e-01_rb,& + & 8.883724e-01_rb,8.895810e-01_rb,8.907384e-01_rb,8.918456e-01_rb,8.929083e-01_rb,& + & 8.939284e-01_rb,8.949060e-01_rb,8.958463e-01_rb,8.967486e-01_rb,8.976129e-01_rb,& + & 8.984463e-01_rb,8.992439e-01_rb,9.000094e-01_rb,9.007438e-01_rb,9.014496e-01_rb,& + & 9.021235e-01_rb,9.027699e-01_rb,9.033859e-01_rb,9.039772e-01_rb,9.045419e-01_rb,& + & 9.050819e-01_rb,9.055975e-01_rb,9.060907e-01_rb,9.065607e-01_rb,9.070093e-01_rb,& + & 9.074389e-01_rb,9.078475e-01_rb,9.082388e-01_rb,9.086117e-01_rb,9.089678e-01_rb,& + & 9.093081e-01_rb,9.096307e-01_rb,9.099410e-01_rb /) +! BAND 20 asyliq1(:, 20) = (/ & - & 8.063610e-01_rb,7.938147e-01_rb,7.921304e-01_rb,7.985092e-01_rb,8.101339e-01_rb,& - & 8.242175e-01_rb,8.379913e-01_rb,8.486920e-01_rb,8.535547e-01_rb,8.498083e-01_rb,& - & 8.224849e-01_rb,8.405509e-01_rb,8.542436e-01_rb,8.640770e-01_rb,8.705653e-01_rb,& - & 8.742227e-01_rb,8.755630e-01_rb,8.751004e-01_rb,8.733491e-01_rb,8.708231e-01_rb,& - & 8.680365e-01_rb,8.655035e-01_rb,8.637381e-01_rb,8.632544e-01_rb,8.645665e-01_rb,& - & 8.681885e-01_rb,8.746346e-01_rb,8.844188e-01_rb,8.648180e-01_rb,8.700563e-01_rb,& - & 8.744672e-01_rb,8.781087e-01_rb,8.810393e-01_rb,8.833174e-01_rb,8.850011e-01_rb,& - & 8.861485e-01_rb,8.868183e-01_rb,8.870687e-01_rb,8.869579e-01_rb,8.865441e-01_rb,& - & 8.858857e-01_rb,8.850412e-01_rb,8.840686e-01_rb,8.830263e-01_rb,8.819726e-01_rb,& - & 8.809658e-01_rb,8.800642e-01_rb,8.793260e-01_rb,8.788099e-01_rb,8.785737e-01_rb,& - & 8.786758e-01_rb,8.791746e-01_rb,8.801283e-01_rb,8.815955e-01_rb,8.836340e-01_rb,& - & 8.863024e-01_rb,8.896592e-01_rb,8.9376e-01_rb /) + & 8.109692e-01_rb,7.846657e-01_rb,7.881928e-01_rb,8.009509e-01_rb,8.131208e-01_rb,& + & 8.230400e-01_rb,8.309448e-01_rb,8.372920e-01_rb,8.424837e-01_rb,8.468166e-01_rb,& + & 8.504947e-01_rb,8.536642e-01_rb,8.564256e-01_rb,8.588513e-01_rb,8.610011e-01_rb,& + & 8.629122e-01_rb,8.646262e-01_rb,8.661720e-01_rb,8.675752e-01_rb,8.688582e-01_rb,& + & 8.700379e-01_rb,8.711300e-01_rb,8.721485e-01_rb,8.731027e-01_rb,8.740010e-01_rb,& + & 8.748499e-01_rb,8.756564e-01_rb,8.764239e-01_rb,8.771542e-01_rb,8.778523e-01_rb,& + & 8.785211e-01_rb,8.791601e-01_rb,8.797725e-01_rb,8.803589e-01_rb,8.809173e-01_rb,& + & 8.814552e-01_rb,8.819705e-01_rb,8.824611e-01_rb,8.829311e-01_rb,8.833791e-01_rb,& + & 8.838078e-01_rb,8.842148e-01_rb,8.846044e-01_rb,8.849756e-01_rb,8.853291e-01_rb,& + & 8.856645e-01_rb,8.859841e-01_rb,8.862904e-01_rb,8.865801e-01_rb,8.868551e-01_rb,& + & 8.871182e-01_rb,8.873673e-01_rb,8.876059e-01_rb,8.878307e-01_rb,8.880462e-01_rb,& + & 8.882501e-01_rb,8.884453e-01_rb,8.886339e-01_rb /) +! BAND 21 asyliq1(:, 21) = (/ & - & 7.885899e-01_rb,7.937172e-01_rb,8.020658e-01_rb,8.123971e-01_rb,8.235502e-01_rb,& - & 8.343776e-01_rb,8.437336e-01_rb,8.504711e-01_rb,8.534421e-01_rb,8.514978e-01_rb,& - & 8.238888e-01_rb,8.417463e-01_rb,8.552057e-01_rb,8.647853e-01_rb,8.710038e-01_rb,& - & 8.743798e-01_rb,8.754319e-01_rb,8.746786e-01_rb,8.726386e-01_rb,8.698303e-01_rb,& - & 8.667724e-01_rb,8.639836e-01_rb,8.619823e-01_rb,8.612870e-01_rb,8.624165e-01_rb,& - & 8.658893e-01_rb,8.722241e-01_rb,8.819394e-01_rb,8.620216e-01_rb,8.671239e-01_rb,& - & 8.713983e-01_rb,8.749032e-01_rb,8.776970e-01_rb,8.798385e-01_rb,8.813860e-01_rb,& - & 8.823980e-01_rb,8.829332e-01_rb,8.830500e-01_rb,8.828068e-01_rb,8.822623e-01_rb,& - & 8.814750e-01_rb,8.805031e-01_rb,8.794056e-01_rb,8.782407e-01_rb,8.770672e-01_rb,& - & 8.759432e-01_rb,8.749275e-01_rb,8.740784e-01_rb,8.734547e-01_rb,8.731146e-01_rb,& - & 8.731170e-01_rb,8.735199e-01_rb,8.743823e-01_rb,8.757625e-01_rb,8.777191e-01_rb,& - & 8.803105e-01_rb,8.835953e-01_rb,8.8763e-01_rb /) + & 7.838510e-01_rb,7.803151e-01_rb,7.980477e-01_rb,8.144160e-01_rb,8.261784e-01_rb,& + & 8.344240e-01_rb,8.404278e-01_rb,8.450391e-01_rb,8.487593e-01_rb,8.518741e-01_rb,& + & 8.545484e-01_rb,8.568890e-01_rb,8.589560e-01_rb,8.607983e-01_rb,8.624504e-01_rb,& + & 8.639408e-01_rb,8.652945e-01_rb,8.665301e-01_rb,8.676634e-01_rb,8.687121e-01_rb,& + & 8.696855e-01_rb,8.705933e-01_rb,8.714448e-01_rb,8.722454e-01_rb,8.730014e-01_rb,& + & 8.737180e-01_rb,8.743982e-01_rb,8.750436e-01_rb,8.756598e-01_rb,8.762481e-01_rb,& + & 8.768089e-01_rb,8.773427e-01_rb,8.778532e-01_rb,8.783434e-01_rb,8.788089e-01_rb,& + & 8.792530e-01_rb,8.796784e-01_rb,8.800845e-01_rb,8.804716e-01_rb,8.808411e-01_rb,& + & 8.811923e-01_rb,8.815276e-01_rb,8.818472e-01_rb,8.821504e-01_rb,8.824408e-01_rb,& + & 8.827155e-01_rb,8.829777e-01_rb,8.832269e-01_rb,8.834631e-01_rb,8.836892e-01_rb,& + & 8.839034e-01_rb,8.841075e-01_rb,8.843021e-01_rb,8.844866e-01_rb,8.846631e-01_rb,& + & 8.848304e-01_rb,8.849910e-01_rb,8.851425e-01_rb /) +! BAND 22 asyliq1(:, 22) = (/ & - & 7.811516e-01_rb,7.962229e-01_rb,8.096199e-01_rb,8.212996e-01_rb,8.312212e-01_rb,& - & 8.393430e-01_rb,8.456236e-01_rb,8.500214e-01_rb,8.524950e-01_rb,8.530031e-01_rb,& - & 8.251485e-01_rb,8.429043e-01_rb,8.562461e-01_rb,8.656954e-01_rb,8.717737e-01_rb,& - & 8.750020e-01_rb,8.759022e-01_rb,8.749953e-01_rb,8.728027e-01_rb,8.698461e-01_rb,& - & 8.666466e-01_rb,8.637257e-01_rb,8.616047e-01_rb,8.608051e-01_rb,8.618483e-01_rb,& - & 8.652557e-01_rb,8.715487e-01_rb,8.812485e-01_rb,8.611645e-01_rb,8.662052e-01_rb,& - & 8.704173e-01_rb,8.738594e-01_rb,8.765901e-01_rb,8.786678e-01_rb,8.801517e-01_rb,& - & 8.810999e-01_rb,8.815713e-01_rb,8.816246e-01_rb,8.813185e-01_rb,8.807114e-01_rb,& - & 8.798621e-01_rb,8.788290e-01_rb,8.776713e-01_rb,8.764470e-01_rb,8.752152e-01_rb,& - & 8.740343e-01_rb,8.729631e-01_rb,8.720602e-01_rb,8.713842e-01_rb,8.709936e-01_rb,& - & 8.709475e-01_rb,8.713041e-01_rb,8.721221e-01_rb,8.734602e-01_rb,8.753774e-01_rb,& - & 8.779319e-01_rb,8.811825e-01_rb,8.8519e-01_rb /) + & 7.760783e-01_rb,7.890215e-01_rb,8.090192e-01_rb,8.230252e-01_rb,8.321369e-01_rb,& + & 8.384258e-01_rb,8.431529e-01_rb,8.469558e-01_rb,8.501499e-01_rb,8.528899e-01_rb,& + & 8.552899e-01_rb,8.573956e-01_rb,8.592570e-01_rb,8.609098e-01_rb,8.623897e-01_rb,& + & 8.637169e-01_rb,8.649184e-01_rb,8.660097e-01_rb,8.670096e-01_rb,8.679338e-01_rb,& + & 8.687896e-01_rb,8.695880e-01_rb,8.703365e-01_rb,8.710422e-01_rb,8.717092e-01_rb,& + & 8.723378e-01_rb,8.729363e-01_rb,8.735063e-01_rb,8.740475e-01_rb,8.745661e-01_rb,& + & 8.750560e-01_rb,8.755275e-01_rb,8.759731e-01_rb,8.764000e-01_rb,8.768071e-01_rb,& + & 8.771942e-01_rb,8.775628e-01_rb,8.779126e-01_rb,8.782483e-01_rb,8.785626e-01_rb,& + & 8.788610e-01_rb,8.791482e-01_rb,8.794180e-01_rb,8.796765e-01_rb,8.799207e-01_rb,& + & 8.801522e-01_rb,8.803707e-01_rb,8.805777e-01_rb,8.807749e-01_rb,8.809605e-01_rb,& + & 8.811362e-01_rb,8.813047e-01_rb,8.814647e-01_rb,8.816131e-01_rb,8.817588e-01_rb,& + & 8.818930e-01_rb,8.820230e-01_rb,8.821445e-01_rb /) +! BAND 23 asyliq1(:, 23) = (/ & - & 7.865744e-01_rb,8.093340e-01_rb,8.257596e-01_rb,8.369940e-01_rb,8.441574e-01_rb,& - & 8.483602e-01_rb,8.507096e-01_rb,8.523139e-01_rb,8.542834e-01_rb,8.577321e-01_rb,& - & 8.288960e-01_rb,8.465308e-01_rb,8.597175e-01_rb,8.689830e-01_rb,8.748542e-01_rb,& - & 8.778584e-01_rb,8.785222e-01_rb,8.773728e-01_rb,8.749370e-01_rb,8.717419e-01_rb,& - & 8.683145e-01_rb,8.651816e-01_rb,8.628704e-01_rb,8.619077e-01_rb,8.628205e-01_rb,& - & 8.661356e-01_rb,8.723803e-01_rb,8.820815e-01_rb,8.616715e-01_rb,8.666389e-01_rb,& - & 8.707753e-01_rb,8.741398e-01_rb,8.767912e-01_rb,8.787885e-01_rb,8.801908e-01_rb,& - & 8.810570e-01_rb,8.814460e-01_rb,8.814167e-01_rb,8.810283e-01_rb,8.803395e-01_rb,& - & 8.794095e-01_rb,8.782971e-01_rb,8.770613e-01_rb,8.757610e-01_rb,8.744553e-01_rb,& - & 8.732031e-01_rb,8.720634e-01_rb,8.710951e-01_rb,8.703572e-01_rb,8.699086e-01_rb,& - & 8.698084e-01_rb,8.701155e-01_rb,8.708887e-01_rb,8.721872e-01_rb,8.740698e-01_rb,& - & 8.765957e-01_rb,8.798235e-01_rb,8.8381e-01_rb /) + & 7.847907e-01_rb,8.099917e-01_rb,8.257428e-01_rb,8.350423e-01_rb,8.411971e-01_rb,& + & 8.457241e-01_rb,8.493010e-01_rb,8.522565e-01_rb,8.547660e-01_rb,8.569311e-01_rb,& + & 8.588181e-01_rb,8.604729e-01_rb,8.619296e-01_rb,8.632208e-01_rb,8.643725e-01_rb,& + & 8.654050e-01_rb,8.663363e-01_rb,8.671835e-01_rb,8.679590e-01_rb,8.686707e-01_rb,& + & 8.693308e-01_rb,8.699433e-01_rb,8.705147e-01_rb,8.710490e-01_rb,8.715497e-01_rb,& + & 8.720219e-01_rb,8.724669e-01_rb,8.728849e-01_rb,8.732806e-01_rb,8.736550e-01_rb,& + & 8.740099e-01_rb,8.743435e-01_rb,8.746601e-01_rb,8.749610e-01_rb,8.752449e-01_rb,& + & 8.755143e-01_rb,8.757688e-01_rb,8.760095e-01_rb,8.762375e-01_rb,8.764532e-01_rb,& + & 8.766579e-01_rb,8.768506e-01_rb,8.770323e-01_rb,8.772049e-01_rb,8.773690e-01_rb,& + & 8.775226e-01_rb,8.776679e-01_rb,8.778062e-01_rb,8.779360e-01_rb,8.780587e-01_rb,& + & 8.781747e-01_rb,8.782852e-01_rb,8.783892e-01_rb,8.784891e-01_rb,8.785824e-01_rb,& + & 8.786705e-01_rb,8.787546e-01_rb,8.788336e-01_rb /) +! BAND 24 asyliq1(:, 24) = (/ & - & 8.069513e-01_rb,8.262939e-01_rb,8.398241e-01_rb,8.486352e-01_rb,8.538213e-01_rb,& - & 8.564743e-01_rb,8.576854e-01_rb,8.585455e-01_rb,8.601452e-01_rb,8.635755e-01_rb,& - & 8.337383e-01_rb,8.512655e-01_rb,8.643049e-01_rb,8.733896e-01_rb,8.790535e-01_rb,& - & 8.818295e-01_rb,8.822518e-01_rb,8.808533e-01_rb,8.781676e-01_rb,8.747284e-01_rb,& - & 8.710690e-01_rb,8.677229e-01_rb,8.652236e-01_rb,8.641047e-01_rb,8.648993e-01_rb,& - & 8.681413e-01_rb,8.743640e-01_rb,8.841007e-01_rb,8.633558e-01_rb,8.682719e-01_rb,& - & 8.723543e-01_rb,8.756621e-01_rb,8.782547e-01_rb,8.801915e-01_rb,8.815318e-01_rb,& - & 8.823347e-01_rb,8.826598e-01_rb,8.825663e-01_rb,8.821135e-01_rb,8.813608e-01_rb,& - & 8.803674e-01_rb,8.791928e-01_rb,8.778960e-01_rb,8.765366e-01_rb,8.751738e-01_rb,& - & 8.738670e-01_rb,8.726755e-01_rb,8.716585e-01_rb,8.708755e-01_rb,8.703856e-01_rb,& - & 8.702483e-01_rb,8.705229e-01_rb,8.712687e-01_rb,8.725448e-01_rb,8.744109e-01_rb,& - & 8.769260e-01_rb,8.801496e-01_rb,8.8414e-01_rb /) + & 8.054324e-01_rb,8.266282e-01_rb,8.378075e-01_rb,8.449848e-01_rb,8.502166e-01_rb,& + & 8.542268e-01_rb,8.573477e-01_rb,8.598022e-01_rb,8.617689e-01_rb,8.633859e-01_rb,& + & 8.647536e-01_rb,8.659354e-01_rb,8.669807e-01_rb,8.679143e-01_rb,8.687577e-01_rb,& + & 8.695222e-01_rb,8.702207e-01_rb,8.708591e-01_rb,8.714446e-01_rb,8.719836e-01_rb,& + & 8.724812e-01_rb,8.729426e-01_rb,8.733689e-01_rb,8.737665e-01_rb,8.741373e-01_rb,& + & 8.744834e-01_rb,8.748070e-01_rb,8.751131e-01_rb,8.754011e-01_rb,8.756676e-01_rb,& + & 8.759219e-01_rb,8.761599e-01_rb,8.763857e-01_rb,8.765984e-01_rb,8.767999e-01_rb,& + & 8.769889e-01_rb,8.771669e-01_rb,8.773373e-01_rb,8.774969e-01_rb,8.776469e-01_rb,& + & 8.777894e-01_rb,8.779237e-01_rb,8.780505e-01_rb,8.781703e-01_rb,8.782820e-01_rb,& + & 8.783886e-01_rb,8.784894e-01_rb,8.785844e-01_rb,8.786736e-01_rb,8.787584e-01_rb,& + & 8.788379e-01_rb,8.789130e-01_rb,8.789849e-01_rb,8.790506e-01_rb,8.791141e-01_rb,& + & 8.791750e-01_rb,8.792324e-01_rb,8.792867e-01_rb /) +! BAND 25 asyliq1(:, 25) = (/ & - & 8.252182e-01_rb,8.379244e-01_rb,8.471709e-01_rb,8.535760e-01_rb,8.577540e-01_rb,& - & 8.603183e-01_rb,8.618820e-01_rb,8.630578e-01_rb,8.644587e-01_rb,8.666970e-01_rb,& - & 8.362159e-01_rb,8.536817e-01_rb,8.666387e-01_rb,8.756240e-01_rb,8.811746e-01_rb,& - & 8.838273e-01_rb,8.841191e-01_rb,8.825871e-01_rb,8.797681e-01_rb,8.761992e-01_rb,& - & 8.724174e-01_rb,8.689593e-01_rb,8.663623e-01_rb,8.651632e-01_rb,8.658988e-01_rb,& - & 8.691064e-01_rb,8.753226e-01_rb,8.850847e-01_rb,8.641620e-01_rb,8.690500e-01_rb,& - & 8.731026e-01_rb,8.763795e-01_rb,8.789400e-01_rb,8.808438e-01_rb,8.821503e-01_rb,& - & 8.829191e-01_rb,8.832095e-01_rb,8.830813e-01_rb,8.825938e-01_rb,8.818064e-01_rb,& - & 8.807787e-01_rb,8.795704e-01_rb,8.782408e-01_rb,8.768493e-01_rb,8.754557e-01_rb,& - & 8.741193e-01_rb,8.728995e-01_rb,8.718561e-01_rb,8.710484e-01_rb,8.705360e-01_rb,& - & 8.703782e-01_rb,8.706347e-01_rb,8.713650e-01_rb,8.726285e-01_rb,8.744849e-01_rb,& - & 8.769933e-01_rb,8.802136e-01_rb,8.8421e-01_rb /) + & 8.249534e-01_rb,8.391988e-01_rb,8.474107e-01_rb,8.526860e-01_rb,8.563983e-01_rb,& + & 8.592389e-01_rb,8.615144e-01_rb,8.633790e-01_rb,8.649325e-01_rb,8.662504e-01_rb,& + & 8.673841e-01_rb,8.683741e-01_rb,8.692495e-01_rb,8.700309e-01_rb,8.707328e-01_rb,& + & 8.713650e-01_rb,8.719432e-01_rb,8.724676e-01_rb,8.729498e-01_rb,8.733922e-01_rb,& + & 8.737981e-01_rb,8.741745e-01_rb,8.745225e-01_rb,8.748467e-01_rb,8.751512e-01_rb,& + & 8.754315e-01_rb,8.756962e-01_rb,8.759450e-01_rb,8.761774e-01_rb,8.763945e-01_rb,& + & 8.766021e-01_rb,8.767970e-01_rb,8.769803e-01_rb,8.771511e-01_rb,8.773151e-01_rb,& + & 8.774689e-01_rb,8.776147e-01_rb,8.777533e-01_rb,8.778831e-01_rb,8.780050e-01_rb,& + & 8.781197e-01_rb,8.782301e-01_rb,8.783323e-01_rb,8.784312e-01_rb,8.785222e-01_rb,& + & 8.786096e-01_rb,8.786916e-01_rb,8.787688e-01_rb,8.788411e-01_rb,8.789122e-01_rb,& + & 8.789762e-01_rb,8.790373e-01_rb,8.790954e-01_rb,8.791514e-01_rb,8.792018e-01_rb,& + & 8.792517e-01_rb,8.792990e-01_rb,8.793429e-01_rb /) +! BAND 26 asyliq1(:, 26) = (/ & - & 8.370583e-01_rb,8.467920e-01_rb,8.537769e-01_rb,8.585136e-01_rb,8.615034e-01_rb,& - & 8.632474e-01_rb,8.642468e-01_rb,8.650026e-01_rb,8.660161e-01_rb,8.677882e-01_rb,& - & 8.369760e-01_rb,8.543821e-01_rb,8.672699e-01_rb,8.761782e-01_rb,8.816454e-01_rb,& - & 8.842103e-01_rb,8.844114e-01_rb,8.827872e-01_rb,8.798766e-01_rb,8.762179e-01_rb,& - & 8.723500e-01_rb,8.688112e-01_rb,8.661403e-01_rb,8.648758e-01_rb,8.655563e-01_rb,& - & 8.687206e-01_rb,8.749072e-01_rb,8.846546e-01_rb,8.636289e-01_rb,8.684849e-01_rb,& - & 8.725054e-01_rb,8.757501e-01_rb,8.782785e-01_rb,8.801503e-01_rb,8.814249e-01_rb,& - & 8.821620e-01_rb,8.824211e-01_rb,8.822620e-01_rb,8.817440e-01_rb,8.809268e-01_rb,& - & 8.798699e-01_rb,8.786330e-01_rb,8.772756e-01_rb,8.758572e-01_rb,8.744374e-01_rb,& - & 8.730760e-01_rb,8.718323e-01_rb,8.707660e-01_rb,8.699366e-01_rb,8.694039e-01_rb,& - & 8.692271e-01_rb,8.694661e-01_rb,8.701803e-01_rb,8.714293e-01_rb,8.732727e-01_rb,& - & 8.757702e-01_rb,8.789811e-01_rb,8.8297e-01_rb /) + & 8.323091e-01_rb,8.429776e-01_rb,8.498123e-01_rb,8.546929e-01_rb,8.584295e-01_rb,& + & 8.613489e-01_rb,8.636324e-01_rb,8.654303e-01_rb,8.668675e-01_rb,8.680404e-01_rb,& + & 8.690174e-01_rb,8.698495e-01_rb,8.705666e-01_rb,8.711961e-01_rb,8.717556e-01_rb,& + & 8.722546e-01_rb,8.727063e-01_rb,8.731170e-01_rb,8.734933e-01_rb,8.738382e-01_rb,& + & 8.741590e-01_rb,8.744525e-01_rb,8.747295e-01_rb,8.749843e-01_rb,8.752210e-01_rb,& + & 8.754437e-01_rb,8.756524e-01_rb,8.758472e-01_rb,8.760288e-01_rb,8.762030e-01_rb,& + & 8.763603e-01_rb,8.765122e-01_rb,8.766539e-01_rb,8.767894e-01_rb,8.769130e-01_rb,& + & 8.770310e-01_rb,8.771422e-01_rb,8.772437e-01_rb,8.773419e-01_rb,8.774355e-01_rb,& + & 8.775221e-01_rb,8.776047e-01_rb,8.776802e-01_rb,8.777539e-01_rb,8.778216e-01_rb,& + & 8.778859e-01_rb,8.779473e-01_rb,8.780031e-01_rb,8.780562e-01_rb,8.781097e-01_rb,& + & 8.781570e-01_rb,8.782021e-01_rb,8.782463e-01_rb,8.782845e-01_rb,8.783235e-01_rb,& + & 8.783610e-01_rb,8.783953e-01_rb,8.784273e-01_rb /) +! BAND 27 asyliq1(:, 27) = (/ & - & 8.430819e-01_rb,8.510060e-01_rb,8.567270e-01_rb,8.606533e-01_rb,8.631934e-01_rb,& - & 8.647554e-01_rb,8.657471e-01_rb,8.665760e-01_rb,8.676496e-01_rb,8.693754e-01_rb,& - & 8.384298e-01_rb,8.557913e-01_rb,8.686214e-01_rb,8.774605e-01_rb,8.828495e-01_rb,& - & 8.853287e-01_rb,8.854393e-01_rb,8.837215e-01_rb,8.807161e-01_rb,8.769639e-01_rb,& - & 8.730053e-01_rb,8.693812e-01_rb,8.666321e-01_rb,8.652988e-01_rb,8.659219e-01_rb,& - & 8.690419e-01_rb,8.751999e-01_rb,8.849360e-01_rb,8.638013e-01_rb,8.686371e-01_rb,& - & 8.726369e-01_rb,8.758605e-01_rb,8.783674e-01_rb,8.802176e-01_rb,8.814705e-01_rb,& - & 8.821859e-01_rb,8.824234e-01_rb,8.822429e-01_rb,8.817038e-01_rb,8.808658e-01_rb,& - & 8.797887e-01_rb,8.785323e-01_rb,8.771560e-01_rb,8.757196e-01_rb,8.742828e-01_rb,& - & 8.729052e-01_rb,8.716467e-01_rb,8.705666e-01_rb,8.697250e-01_rb,8.691812e-01_rb,& - & 8.689950e-01_rb,8.692264e-01_rb,8.699346e-01_rb,8.711795e-01_rb,8.730209e-01_rb,& - & 8.755181e-01_rb,8.787312e-01_rb,8.8272e-01_rb /) + & 8.396448e-01_rb,8.480172e-01_rb,8.535934e-01_rb,8.574145e-01_rb,8.600835e-01_rb,& + & 8.620347e-01_rb,8.635500e-01_rb,8.648003e-01_rb,8.658758e-01_rb,8.668248e-01_rb,& + & 8.676697e-01_rb,8.684220e-01_rb,8.690893e-01_rb,8.696807e-01_rb,8.702046e-01_rb,& + & 8.706676e-01_rb,8.710798e-01_rb,8.714478e-01_rb,8.717778e-01_rb,8.720747e-01_rb,& + & 8.723431e-01_rb,8.725889e-01_rb,8.728144e-01_rb,8.730201e-01_rb,8.732129e-01_rb,& + & 8.733907e-01_rb,8.735541e-01_rb,8.737100e-01_rb,8.738533e-01_rb,8.739882e-01_rb,& + & 8.741164e-01_rb,8.742362e-01_rb,8.743485e-01_rb,8.744530e-01_rb,8.745512e-01_rb,& + & 8.746471e-01_rb,8.747373e-01_rb,8.748186e-01_rb,8.748973e-01_rb,8.749732e-01_rb,& + & 8.750443e-01_rb,8.751105e-01_rb,8.751747e-01_rb,8.752344e-01_rb,8.752902e-01_rb,& + & 8.753412e-01_rb,8.753917e-01_rb,8.754393e-01_rb,8.754843e-01_rb,8.755282e-01_rb,& + & 8.755662e-01_rb,8.756039e-01_rb,8.756408e-01_rb,8.756722e-01_rb,8.757072e-01_rb,& + & 8.757352e-01_rb,8.757653e-01_rb,8.757932e-01_rb /) +! BAND 28 asyliq1(:, 28) = (/ & - & 8.452284e-01_rb,8.522700e-01_rb,8.572973e-01_rb,8.607031e-01_rb,8.628802e-01_rb,& - & 8.642215e-01_rb,8.651198e-01_rb,8.659679e-01_rb,8.671588e-01_rb,8.690853e-01_rb,& - & 8.383803e-01_rb,8.557485e-01_rb,8.685851e-01_rb,8.774303e-01_rb,8.828245e-01_rb,& - & 8.853077e-01_rb,8.854207e-01_rb,8.837034e-01_rb,8.806962e-01_rb,8.769398e-01_rb,& - & 8.729740e-01_rb,8.693393e-01_rb,8.665761e-01_rb,8.652247e-01_rb,8.658253e-01_rb,& - & 8.689182e-01_rb,8.750438e-01_rb,8.847424e-01_rb,8.636140e-01_rb,8.684449e-01_rb,& - & 8.724400e-01_rb,8.756589e-01_rb,8.781613e-01_rb,8.800072e-01_rb,8.812559e-01_rb,& - & 8.819671e-01_rb,8.822007e-01_rb,8.820165e-01_rb,8.814737e-01_rb,8.806322e-01_rb,& - & 8.795518e-01_rb,8.782923e-01_rb,8.769129e-01_rb,8.754737e-01_rb,8.740342e-01_rb,& - & 8.726542e-01_rb,8.713934e-01_rb,8.703111e-01_rb,8.694677e-01_rb,8.689222e-01_rb,& - & 8.687344e-01_rb,8.689646e-01_rb,8.696715e-01_rb,8.709156e-01_rb,8.727563e-01_rb,& - & 8.752531e-01_rb,8.784659e-01_rb,8.8245e-01_rb /) + & 8.374590e-01_rb,8.465669e-01_rb,8.518701e-01_rb,8.547627e-01_rb,8.565745e-01_rb,& + & 8.579065e-01_rb,8.589717e-01_rb,8.598632e-01_rb,8.606363e-01_rb,8.613268e-01_rb,& + & 8.619560e-01_rb,8.625340e-01_rb,8.630689e-01_rb,8.635601e-01_rb,8.640084e-01_rb,& + & 8.644180e-01_rb,8.647885e-01_rb,8.651220e-01_rb,8.654218e-01_rb,8.656908e-01_rb,& + & 8.659294e-01_rb,8.661422e-01_rb,8.663334e-01_rb,8.665037e-01_rb,8.666543e-01_rb,& + & 8.667913e-01_rb,8.669156e-01_rb,8.670242e-01_rb,8.671249e-01_rb,8.672161e-01_rb,& + & 8.672993e-01_rb,8.673733e-01_rb,8.674457e-01_rb,8.675103e-01_rb,8.675713e-01_rb,& + & 8.676267e-01_rb,8.676798e-01_rb,8.677286e-01_rb,8.677745e-01_rb,8.678178e-01_rb,& + & 8.678601e-01_rb,8.678986e-01_rb,8.679351e-01_rb,8.679693e-01_rb,8.680013e-01_rb,& + & 8.680334e-01_rb,8.680624e-01_rb,8.680915e-01_rb,8.681178e-01_rb,8.681428e-01_rb,& + & 8.681654e-01_rb,8.681899e-01_rb,8.682103e-01_rb,8.682317e-01_rb,8.682498e-01_rb,& + & 8.682677e-01_rb,8.682861e-01_rb,8.683041e-01_rb /) +! BAND 29 asyliq1(:, 29) = (/ & - & 7.800869e-01_rb,8.091120e-01_rb,8.325369e-01_rb,8.466266e-01_rb,8.515495e-01_rb,& - & 8.499371e-01_rb,8.456203e-01_rb,8.430521e-01_rb,8.470286e-01_rb,8.625431e-01_rb,& - & 8.402261e-01_rb,8.610822e-01_rb,8.776608e-01_rb,8.904485e-01_rb,8.999294e-01_rb,& - & 9.065860e-01_rb,9.108995e-01_rb,9.133503e-01_rb,9.144187e-01_rb,9.145855e-01_rb,& - & 9.143320e-01_rb,9.141402e-01_rb,9.144933e-01_rb,9.158754e-01_rb,9.187716e-01_rb,& - & 9.236677e-01_rb,9.310503e-01_rb,9.414058e-01_rb,9.239108e-01_rb,9.300719e-01_rb,& - & 9.353612e-01_rb,9.398378e-01_rb,9.435609e-01_rb,9.465895e-01_rb,9.489829e-01_rb,& - & 9.508000e-01_rb,9.521002e-01_rb,9.529424e-01_rb,9.533860e-01_rb,9.534902e-01_rb,& - & 9.533143e-01_rb,9.529177e-01_rb,9.523596e-01_rb,9.516997e-01_rb,9.509973e-01_rb,& - & 9.503121e-01_rb,9.497037e-01_rb,9.492317e-01_rb,9.489558e-01_rb,9.489356e-01_rb,& - & 9.492311e-01_rb,9.499019e-01_rb,9.510077e-01_rb,9.526084e-01_rb,9.547636e-01_rb,& - & 9.575331e-01_rb,9.609766e-01_rb,9.6515e-01_rb /) + & 7.877069e-01_rb,8.244281e-01_rb,8.367971e-01_rb,8.409074e-01_rb,8.429859e-01_rb,& + & 8.454386e-01_rb,8.489350e-01_rb,8.534141e-01_rb,8.585814e-01_rb,8.641267e-01_rb,& + & 8.697999e-01_rb,8.754223e-01_rb,8.808785e-01_rb,8.860944e-01_rb,8.910354e-01_rb,& + & 8.956837e-01_rb,9.000392e-01_rb,9.041091e-01_rb,9.079071e-01_rb,9.114479e-01_rb,& + & 9.147462e-01_rb,9.178234e-01_rb,9.206903e-01_rb,9.233663e-01_rb,9.258668e-01_rb,& + & 9.282006e-01_rb,9.303847e-01_rb,9.324288e-01_rb,9.343418e-01_rb,9.361356e-01_rb,& + & 9.378176e-01_rb,9.393939e-01_rb,9.408736e-01_rb,9.422622e-01_rb,9.435670e-01_rb,& + & 9.447900e-01_rb,9.459395e-01_rb,9.470199e-01_rb,9.480335e-01_rb,9.489852e-01_rb,& + & 9.498782e-01_rb,9.507168e-01_rb,9.515044e-01_rb,9.522470e-01_rb,9.529409e-01_rb,& + & 9.535946e-01_rb,9.542071e-01_rb,9.547838e-01_rb,9.553256e-01_rb,9.558351e-01_rb,& + & 9.563139e-01_rb,9.567660e-01_rb,9.571915e-01_rb,9.575901e-01_rb,9.579685e-01_rb,& + & 9.583239e-01_rb,9.586602e-01_rb,9.589766e-01_rb /) + ! Spherical Ice Particle Parameterization ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)] diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F index 068c9492c5..3515bc3d89 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F @@ -4,7 +4,7 @@ MODULE module_sf_bem ! ----------------------------------------------------------------------- #ifdef mpas - USE mpas_dmpar, only : mpas_dmpar_global_abort +!USE mpas_dmpar, only : mpas_dmpar_global_abort #define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) #else #define FATAL_ERROR(M) write(0,*) M ; stop diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F index 0b452e765e..602ae15e3f 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F @@ -1,7 +1,7 @@ MODULE module_sf_bep #ifdef mpas - USE mpas_dmpar, only : mpas_dmpar_global_abort +!USE mpas_dmpar, only : mpas_dmpar_global_abort #define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) #else #define FATAL_ERROR(M) write(0,*) M ; stop diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F index f8d25a061d..f6da2724c2 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F @@ -1,7 +1,7 @@ MODULE module_sf_bep_bem #ifdef mpas - USE mpas_dmpar, only : mpas_dmpar_global_abort +!USE mpas_dmpar, only : mpas_dmpar_global_abort #define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) #else #define FATAL_ERROR(M) write(0,*) M ; stop diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F index 72d8e62b8c..c4e680b1e8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F @@ -3,6 +3,7 @@ MODULE module_sf_noahlsm #if defined(mpas) !MPAS specific (Laura D. Fowler): use mpas_atmphys_constants, rhowater => rho_w +use mpas_atmphys_utilities #else USE module_model_constants #endif @@ -2347,13 +2348,13 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & ! ---------------------------------------------------------------------- ! IF (SOILTYP .gt. SLCATS) THEN -! CALL wrf_error_fatal ( 'Warning: too many input soil types' ) + CALL physics_error_fatal ( 'Warning: too many input soil types' ) END IF IF (VEGTYP .gt. LUCATS) THEN -! CALL wrf_error_fatal ( 'Warning: too many input landuse types' ) + CALL physics_error_fatal ( 'Warning: too many input landuse types' ) END IF IF (SLOPETYP .gt. SLPCATS) THEN -! CALL wrf_error_fatal ( 'Warning: too many input slope types' ) + CALL physics_error_fatal ( 'Warning: too many input slope types' ) END IF ! ---------------------------------------------------------------------- diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index 49e96e18ed..8664c4acb6 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -20,6 +20,9 @@ all: core_hyd core_hyd: $(OBJS) ar -ru libdycore.a $(OBJS) +core_reg: + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml + mpas_init_atm_cases.o: \ read_geogrid.o \ mpas_atm_advection.o \ @@ -60,6 +63,10 @@ mpas_atmphys_initialize_real.o: \ clean: $(RM) *.o *.mod *.f90 libdycore.a + $(RM) Registry_processed.xml + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: $(RM) $@ $*.mod diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 96c59cf21a..3a7af503fc 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -30,38 +30,39 @@ - + - - - + + + - - + + - - + + - + - + - - - - + + + + + - - - - + + + + - + @@ -69,152 +70,441 @@ - - - - - - - + + - - - - - + + + + + - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - + + + - - - - - - - - - - - + + + + + + + + + + + + - - - - - - - - - - - + + + + + + + + + + + - - - - - - - - - - - + + + + + + + + + + + - + - - - + + + - - + + - - + + - + - - - - - - + + + + + + - - - + + + @@ -223,61 +513,61 @@ - - - - - + + + + + - - - - - + + + + + - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + - - - + + + - - - - - - - - - + + + + + + + + + - + - - - + + + - + @@ -287,6 +577,6 @@ - + diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F deleted file mode 120000 index eeaf7c089d..0000000000 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ /dev/null @@ -1 +0,0 @@ -../core_atmosphere/dynamics/mpas_atm_advection.F \ No newline at end of file diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F new file mode 100644 index 0000000000..73a280caa8 --- /dev/null +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -0,0 +1,973 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +module atm_advection + + use mpas_kind_types + use mpas_grid_types + use mpas_constants + + + contains + + + subroutine atm_initialize_advection_rk( mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius ) + +! +! compute the cell coefficients for the polynomial fit. +! this is performed during setup for model integration. +! WCS, 31 August 2009 +! + implicit none + + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells, nEdges, maxEdges + logical, intent(in) :: on_a_sphere + real (kind=RKIND), intent(in) :: sphere_radius + + real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: angleEdge, dcEdge + integer, dimension(:,:), pointer :: advCells + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell, edgesOnCell, verticesOnEdge, cellsOnEdge + +! local variables + + real (kind=RKIND), dimension(2,nEdges) :: thetae + real (kind=RKIND), dimension(nCells) :: theta_abs + + real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates + real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere + real (kind=RKIND) :: xec, yec, zec + real (kind=RKIND) :: thetae_tmp + real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2 + integer :: i, j, k, ip1, ip2, n + integer :: iCell, iEdge + real (kind=RKIND) :: pii + real (kind=RKIND), dimension(25) :: xp, yp + + real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25) + real (kind=RKIND) :: length_scale + integer :: ma,na, cell_add, mw + integer, dimension(25) :: cell_list + logical :: add_the_cell, do_the_cell + + real (kind=RKIND) :: cos2t, costsint, sin2t + real (kind=RKIND), dimension(maxEdges) :: angle_2d + + integer, parameter :: polynomial_order = 2 + logical, parameter :: least_squares = .true. + logical, parameter :: reset_poly = .true. + + + pii = 2.*asin(1.0) + + call mpas_pool_get_array(mesh, 'advCells', advCells) + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + + deriv_two(:,:,:) = 0. + + do iCell = 1, nCells ! is this correct? - we need first halo cell also... + + cell_list(1) = iCell + do i=2,nEdgesOnCell(iCell)+1 + cell_list(i) = cellsOnCell(i-1,iCell) + end do + n = nEdgesOnCell(iCell) + 1 + + if ( polynomial_order > 2 ) then + do i=2,nEdgesOnCell(iCell) + 1 + do j=1,nEdgesOnCell( cell_list(i) ) + cell_add = cellsOnCell(j,cell_list(i)) + add_the_cell = .true. + do k=1,n + if ( cell_add == cell_list(k) ) add_the_cell = .false. + end do + if (add_the_cell) then + n = n+1 + cell_list(n) = cell_add + end if + end do + end do + end if + + advCells(1,iCell) = n + +! check to see if we are reaching outside the halo + + do_the_cell = .true. + do i=1,n + if (cell_list(i) > nCells) do_the_cell = .false. + end do + + + if ( .not. do_the_cell ) cycle + + +! compute poynomial fit for this cell if all needed neighbors exist + if ( on_a_sphere ) then + + do i=1,n + advCells(i+1,iCell) = cell_list(i) + xc(i) = xCell(advCells(i+1,iCell))/sphere_radius + yc(i) = yCell(advCells(i+1,iCell))/sphere_radius + zc(i) = zCell(advCells(i+1,iCell))/sphere_radius + end do + + ! + ! In case the current cell center lies at exactly z=1.0, the sphere_angle() routine + ! may generate an FPE since the triangle it is given will have a zero side length + ! adjacent to the vertex whose angle we are trying to find; in this case, simply + ! set the value of theta_abs directly + ! + if (zc(1) == 1.0) then + theta_abs(iCell) = pii/2. + else + theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), & + xc(2), yc(2), zc(2), & + 0.0_RKIND, 0.0_RKIND, 1.0_RKIND ) + end if + +! angles from cell center to neighbor centers (thetav) + + do i=1,n-1 + + ip2 = i+2 + if (ip2 > n) ip2 = 2 + + thetav(i) = sphere_angle( xc(1), yc(1), zc(1), & + xc(i+1), yc(i+1), zc(i+1), & + xc(ip2), yc(ip2), zc(ip2) ) + + dl_sphere(i) = sphere_radius*arc_length( xc(1), yc(1), zc(1), & + xc(i+1), yc(i+1), zc(i+1) ) + end do + + length_scale = 1. + do i=1,n-1 + dl_sphere(i) = dl_sphere(i)/length_scale + end do + +! thetat(1) = 0. ! this defines the x direction, cell center 1 -> + thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line + do i=2,n-1 + thetat(i) = thetat(i-1) + thetav(i-1) + end do + + do i=1,n-1 + xp(i) = cos(thetat(i)) * dl_sphere(i) + yp(i) = sin(thetat(i)) * dl_sphere(i) + end do + + else ! On an x-y plane + + do i=1,n-1 + + angle_2d(i) = angleEdge(edgesOnCell(i,iCell)) + iEdge = edgesOnCell(i,iCell) + if ( iCell /= cellsOnEdge(1,iEdge)) & + angle_2d(i) = angle_2d(i) - pii + +! xp(i) = xCell(cell_list(i)) - xCell(iCell) +! yp(i) = yCell(cell_list(i)) - yCell(iCell) + + xp(i) = dcEdge(edgesOnCell(i,iCell)) * cos(angle_2d(i)) + yp(i) = dcEdge(edgesOnCell(i,iCell)) * sin(angle_2d(i)) + + end do + + end if + + + ma = n-1 + mw = nEdgesOnCell(iCell) + + bmatrix = 0. + amatrix = 0. + wmatrix = 0. + + if (polynomial_order == 2) then + na = 6 + ma = ma+1 + + amatrix(1,1) = 1. + wmatrix(1,1) = 1. + do i=2,ma + amatrix(i,1) = 1. + amatrix(i,2) = xp(i-1) + amatrix(i,3) = yp(i-1) + amatrix(i,4) = xp(i-1)**2 + amatrix(i,5) = xp(i-1) * yp(i-1) + amatrix(i,6) = yp(i-1)**2 + + wmatrix(i,i) = 1. + end do + + else if (polynomial_order == 3) then + na = 10 + ma = ma+1 + + amatrix(1,1) = 1. + wmatrix(1,1) = 1. + do i=2,ma + amatrix(i,1) = 1. + amatrix(i,2) = xp(i-1) + amatrix(i,3) = yp(i-1) + + amatrix(i,4) = xp(i-1)**2 + amatrix(i,5) = xp(i-1) * yp(i-1) + amatrix(i,6) = yp(i-1)**2 + + amatrix(i,7) = xp(i-1)**3 + amatrix(i,8) = yp(i-1) * (xp(i-1)**2) + amatrix(i,9) = xp(i-1) * (yp(i-1)**2) + amatrix(i,10) = yp(i-1)**3 + + wmatrix(i,i) = 1. + + end do + + else + na = 15 + ma = ma+1 + + amatrix(1,1) = 1. + wmatrix(1,1) = 1. + do i=2,ma + amatrix(i,1) = 1. + amatrix(i,2) = xp(i-1) + amatrix(i,3) = yp(i-1) + + amatrix(i,4) = xp(i-1)**2 + amatrix(i,5) = xp(i-1) * yp(i-1) + amatrix(i,6) = yp(i-1)**2 + + amatrix(i,7) = xp(i-1)**3 + amatrix(i,8) = yp(i-1) * (xp(i-1)**2) + amatrix(i,9) = xp(i-1) * (yp(i-1)**2) + amatrix(i,10) = yp(i-1)**3 + + amatrix(i,11) = xp(i-1)**4 + amatrix(i,12) = yp(i-1) * (xp(i-1)**3) + amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2) + amatrix(i,14) = xp(i-1) * (yp(i-1)**3) + amatrix(i,15) = yp(i-1)**4 + + wmatrix(i,i) = 1. + + end do + + do i=1,mw + wmatrix(i,i) = 1. + end do + + end if + + call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 ) + + do i=1,nEdgesOnCell(iCell) + ip1 = i+1 + if (ip1 > n-1) ip1 = 1 + + iEdge = edgesOnCell(i,iCell) + xv1 = xVertex(verticesOnEdge(1,iedge))/sphere_radius + yv1 = yVertex(verticesOnEdge(1,iedge))/sphere_radius + zv1 = zVertex(verticesOnEdge(1,iedge))/sphere_radius + xv2 = xVertex(verticesOnEdge(2,iedge))/sphere_radius + yv2 = yVertex(verticesOnEdge(2,iedge))/sphere_radius + zv2 = zVertex(verticesOnEdge(2,iedge))/sphere_radius + + if ( on_a_sphere ) then + call arc_bisect( xv1, yv1, zv1, & + xv2, yv2, zv2, & + xec, yec, zec ) + + thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), & + xc(i+1), yc(i+1), zc(i+1), & + xec, yec, zec ) + thetae_tmp = thetae_tmp + thetat(i) + if (iCell == cellsOnEdge(1,iEdge)) then + thetae(1,edgesOnCell(i,iCell)) = thetae_tmp + else + thetae(2,edgesOnCell(i,iCell)) = thetae_tmp + end if +! else +! +! xe(edgesOnCell(i,iCell)) = 0.5 * (xv1 + xv2) +! ye(edgesOnCell(i,iCell)) = 0.5 * (yv1 + yv2) + + end if + + end do + +! fill second derivative stencil for rk advection + + do i=1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + + + if ( on_a_sphere ) then + if (iCell == cellsOnEdge(1,iEdge)) then + + cos2t = cos(thetae(1,edgesOnCell(i,iCell))) + sin2t = sin(thetae(1,edgesOnCell(i,iCell))) + costsint = cos2t*sin2t + cos2t = cos2t**2 + sin2t = sin2t**2 + + do j=1,n + deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) & + + 2.*costsint*bmatrix(5,j) & + + 2.*sin2t*bmatrix(6,j) + end do + else + + cos2t = cos(thetae(2,edgesOnCell(i,iCell))) + sin2t = sin(thetae(2,edgesOnCell(i,iCell))) + costsint = cos2t*sin2t + cos2t = cos2t**2 + sin2t = sin2t**2 + + do j=1,n + deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) & + + 2.*costsint*bmatrix(5,j) & + + 2.*sin2t*bmatrix(6,j) + end do + end if + + else + + cos2t = cos(angle_2d(i)) + sin2t = sin(angle_2d(i)) + costsint = cos2t*sin2t + cos2t = cos2t**2 + sin2t = sin2t**2 + +! do j=1,n +! +! deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) & +! + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) & +! + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j) +! end do + + if (iCell == cellsOnEdge(1,iEdge)) then + do j=1,n + deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) & + + 2.*costsint*bmatrix(5,j) & + + 2.*sin2t*bmatrix(6,j) + end do + else + do j=1,n + deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) & + + 2.*costsint*bmatrix(5,j) & + + 2.*sin2t*bmatrix(6,j) + end do + end if + + end if + end do + + end do ! end of loop over cells + +! write(0,*) ' check for deriv2 coefficients, iEdge 4 ' +! +! iEdge = 4 +! j = 1 +! iCell = grid % cellsOnEdge % array(1,iEdge) +! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,1,iEdge) +! do j=2,7 +! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,1,iEdge) +! end do +! +! j = 1 +! iCell = grid % cellsOnEdge % array(2,iEdge) +! write(0,*) ' j, icell, coef ',j,iCell,deriv_two(j,2,iEdge) +! do j=2,7 +! write(0,*) ' j, icell, coef ',j,grid % CellsOnCell % array(j-1,iCell),deriv_two(j,2,iEdge) +! end do + + end subroutine atm_initialize_advection_rk + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! FUNCTION SPHERE_ANGLE + ! + ! Computes the angle between arcs AB and AC, given points A, B, and C + ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + real (kind=RKIND) function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz) + + implicit none + + real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz + + real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC + + real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB + real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC + + real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC + real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC + real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC + + real (kind=RKIND) :: s ! Semiperimeter of the triangle + real (kind=RKIND) :: sin_angle + + a = acos(max(min(bx*cx + by*cy + bz*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (3) + b = acos(max(min(ax*cx + ay*cy + az*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (2) + c = acos(max(min(ax*bx + ay*by + az*bz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (1) + + ABx = bx - ax + ABy = by - ay + ABz = bz - az + + ACx = cx - ax + ACy = cy - ay + ACz = cz - az + + Dx = (ABy * ACz) - (ABz * ACy) + Dy = -((ABx * ACz) - (ABz * ACx)) + Dz = (ABx * ACy) - (ABy * ACx) + + s = 0.5*(a + b + c) +! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28) + sin_angle = sqrt(min(1.0_RKIND,max(0.0_RKIND,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28) + + if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then + sphere_angle = 2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND)) + else + sphere_angle = -2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND)) + end if + + end function sphere_angle + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! FUNCTION PLANE_ANGLE + ! + ! Computes the angle between vectors AB and AC, given points A, B, and C, and + ! a vector (u,v,w) normal to the plane. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + real (kind=RKIND) function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w) + + implicit none + + real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w + + real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB + real (kind=RKIND) :: mAB ! The magnitude of AB + real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC + real (kind=RKIND) :: mAC ! The magnitude of AC + + real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC + real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC + real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC + + real (kind=RKIND) :: cos_angle + + ABx = bx - ax + ABy = by - ay + ABz = bz - az + mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0) + + ACx = cx - ax + ACy = cy - ay + ACz = cz - az + mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0) + + + Dx = (ABy * ACz) - (ABz * ACy) + Dy = -((ABx * ACz) - (ABz * ACx)) + Dz = (ABx * ACy) - (ABy * ACx) + + cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC) + + if ((Dx*u + Dy*v + Dz*w) >= 0.0) then + plane_angle = acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND)) + else + plane_angle = -acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND)) + end if + + end function plane_angle + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! FUNCTION ARC_LENGTH + ! + ! Returns the length of the great circle arc from A=(ax, ay, az) to + ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the + ! same sphere centered at the origin. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + real (kind=RKIND) function arc_length(ax, ay, az, bx, by, bz) + + implicit none + + real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz + + real (kind=RKIND) :: r, c + real (kind=RKIND) :: cx, cy, cz + + cx = bx - ax + cy = by - ay + cz = bz - az + +! r = ax*ax + ay*ay + az*az +! c = cx*cx + cy*cy + cz*cz +! +! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r)) + + r = sqrt(ax*ax + ay*ay + az*az) + c = sqrt(cx*cx + cy*cy + cz*cz) +! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r)) + arc_length = r * 2.0 * asin(c/(2.0*r)) + + end function arc_length + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! SUBROUTINE ARC_BISECT + ! + ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from + ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the + ! surface of a sphere centered at the origin. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz) + + implicit none + + real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz + real (kind=RKIND), intent(out) :: cx, cy, cz + + real (kind=RKIND) :: r ! Radius of the sphere + real (kind=RKIND) :: d + + r = sqrt(ax*ax + ay*ay + az*az) + + cx = 0.5*(ax + bx) + cy = 0.5*(ay + by) + cz = 0.5*(az + bz) + + if (cx == 0. .and. cy == 0. .and. cz == 0.) then + write(0,*) 'Error: arc_bisect: A and B are diametrically opposite' + else + d = sqrt(cx*cx + cy*cy + cz*cz) + cx = r * cx / d + cy = r * cy / d + cz = r * cz / d + end if + + end subroutine arc_bisect + + + subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne) + + implicit none + + integer, intent(in) :: m,n,ne + real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in + real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out + + ! local storage + + real (kind=RKIND), dimension(m,n) :: a + real (kind=RKIND), dimension(n,m) :: b + real (kind=RKIND), dimension(m,m) :: w,wt,h + real (kind=RKIND), dimension(n,m) :: at, ath + real (kind=RKIND), dimension(n,n) :: ata, atha, atha_inv +! real (kind=RKIND), dimension(n,n) :: ata_inv + integer, dimension(n) :: indx + + if ( (ne < n) .or. (ne < m) ) then + write(stderrUnit,*) ' error in poly_fit_2 inversion ',m,n,ne + call mpas_dmpar_global_abort('ERROR: in poly_fit_2 inversion') + end if + + a(1:m,1:n) = a_in(1:m,1:n) + w(1:m,1:m) = weights_in(1:m,1:m) + b_out(:,:) = 0. + + wt = transpose(w) + h = matmul(wt,w) + at = transpose(a) + ath = matmul(at,h) + atha = matmul(ath,a) + + ata = matmul(at,a) + +! if (m == n) then +! call migs(a,n,b,indx) +! else + + call migs(atha,n,atha_inv,indx) + + b = matmul(atha_inv,ath) + +! call migs(ata,n,ata_inv,indx) +! b = matmul(ata_inv,at) +! end if + b_out(1:n,1:m) = b(1:n,1:m) + +! do i=1,n +! write(6,*) ' i, indx ',i,indx(i) +! end do +! +! write(6,*) ' ' + + end subroutine poly_fit_2 + + + ! Updated 10/24/2001. + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! ! + ! Please Note: ! + ! ! + ! (1) This computer program is written by Tao Pang in conjunction with ! + ! his book, "An Introduction to Computational Physics," published ! + ! by Cambridge University Press in 1997. ! + ! ! + ! (2) No warranties, express or implied, are made for this program. ! + ! ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE MIGS (A,N,X,INDX) + ! + ! Subroutine to invert matrix A(N,N) with the inverse stored + ! in X(N,N) in the output. Copyright (c) Tao Pang 2001. + ! + IMPLICIT NONE + INTEGER, INTENT (IN) :: N + INTEGER :: I,J,K + INTEGER, INTENT (OUT), DIMENSION (N) :: INDX + REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A + REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X + REAL (kind=RKIND), DIMENSION (N,N) :: B + ! + DO I = 1, N + DO J = 1, N + B(I,J) = 0.0 + END DO + END DO + DO I = 1, N + B(I,I) = 1.0 + END DO + ! + CALL ELGS (A,N,INDX) + ! + DO I = 1, N-1 + DO J = I+1, N + DO K = 1, N + B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K) + END DO + END DO + END DO + ! + DO I = 1, N + X(N,I) = B(INDX(N),I)/A(INDX(N),N) + DO J = N-1, 1, -1 + X(J,I) = B(INDX(J),I) + DO K = J+1, N + X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I) + END DO + X(J,I) = X(J,I)/A(INDX(J),J) + END DO + END DO + END SUBROUTINE MIGS + + + SUBROUTINE ELGS (A,N,INDX) + ! + ! Subroutine to perform the partial-pivoting Gaussian elimination. + ! A(N,N) is the original matrix in the input and transformed matrix + ! plus the pivoting element ratios below the diagonal in the output. + ! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001. + ! + IMPLICIT NONE + INTEGER, INTENT (IN) :: N + INTEGER :: I,J,K,ITMP + INTEGER, INTENT (OUT), DIMENSION (N) :: INDX + REAL (kind=RKIND) :: C1,PI,PI1,PJ + REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A + REAL (kind=RKIND), DIMENSION (N) :: C + ! + ! Initialize the index + ! + DO I = 1, N + INDX(I) = I + END DO + ! + ! Find the rescaling factors, one from each row + ! + DO I = 1, N + C1= 0.0 + DO J = 1, N + C1 = MAX(C1,ABS(A(I,J))) + END DO + C(I) = C1 + END DO + ! + ! Search the pivoting (largest) element from each column + ! + DO J = 1, N-1 + PI1 = 0.0 + DO I = J, N + PI = ABS(A(INDX(I),J))/C(INDX(I)) + IF (PI.GT.PI1) THEN + PI1 = PI + K = I + ENDIF + END DO + ! + ! Interchange the rows via INDX(N) to record pivoting order + ! + ITMP = INDX(J) + INDX(J) = INDX(K) + INDX(K) = ITMP + DO I = J+1, N + PJ = A(INDX(I),J)/A(INDX(J),J) + ! + ! Record pivoting ratios below the diagonal + ! + A(INDX(I),J) = PJ + ! + ! Modify other elements accordingly + ! + DO K = J+1, N + A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K) + END DO + END DO + END DO + ! + END SUBROUTINE ELGS + + + subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere_radius ) + +! +! compute the cell coefficients for the deformation calculations +! WCS, 13 July 2010 +! + implicit none + + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + logical, intent(in) :: on_a_sphere + real (kind=RKIND), intent(in) :: sphere_radius + +! local variables + + real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell + integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + + real (kind=RKIND), dimension(nCells) :: theta_abs + + real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates + real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere + real (kind=RKIND) :: dl + integer :: i, ip1, ip2, n + integer :: iCell + real (kind=RKIND) :: pii + real (kind=RKIND), dimension(25) :: xp, yp + + real (kind=RKIND) :: length_scale + integer, dimension(25) :: cell_list + + integer :: iv + logical :: do_the_cell + real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, area_cellt + + logical, parameter :: debug = .false. + + if (debug) write(0,*) ' in def weight calc ' + + + call mpas_pool_get_array(mesh, 'defc_a', defc_a) + call mpas_pool_get_array(mesh, 'defc_b', defc_b) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + + defc_a(:,:) = 0. + defc_b(:,:) = 0. + + pii = 2.*asin(1.0) + + if (debug) write(0,*) ' beginning cell loop ' + + do iCell = 1, nCells + + if (debug) write(0,*) ' cell loop ', iCell + + cell_list(1) = iCell + do i=2,nEdgesOnCell(iCell)+1 + cell_list(i) = cellsOnCell(i-1,iCell) + end do + n = nEdgesOnCell(iCell) + 1 + +! check to see if we are reaching outside the halo + + if (debug) write(0,*) ' points ', n + + do_the_cell = .true. + do i=1,n + if (cell_list(i) > nCells) do_the_cell = .false. + end do + + + if (.not. do_the_cell) cycle + + +! compute poynomial fit for this cell if all needed neighbors exist + if (on_a_sphere) then + + xc(1) = xCell(iCell)/sphere_radius + yc(1) = yCell(iCell)/sphere_radius + zc(1) = zCell(iCell)/sphere_radius + + + do i=2,n + iv = verticesOnCell(i-1,iCell) + xc(i) = xVertex(iv)/sphere_radius + yc(i) = yVertex(iv)/sphere_radius + zc(i) = zVertex(iv)/sphere_radius + end do + + ! + ! In case the current cell center lies at exactly z=1.0, the sphere_angle() routine + ! may generate an FPE since the triangle it is given will have a zero side length + ! adjacent to the vertex whose angle we are trying to find; in this case, simply + ! set the value of theta_abs directly + ! + if (zc(1) == 1.0) then + theta_abs(iCell) = pii/2. + else + theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), & + xc(2), yc(2), zc(2), & + 0.0_RKIND, 0.0_RKIND, 1.0_RKIND ) + end if + + +! angles from cell center to neighbor centers (thetav) + + do i=1,n-1 + + ip2 = i+2 + if (ip2 > n) ip2 = 2 + + thetav(i) = sphere_angle( xc(1), yc(1), zc(1), & + xc(i+1), yc(i+1), zc(i+1), & + xc(ip2), yc(ip2), zc(ip2) ) + + dl_sphere(i) = sphere_radius*arc_length( xc(1), yc(1), zc(1), & + xc(i+1), yc(i+1), zc(i+1) ) + end do + + length_scale = 1. + do i=1,n-1 + dl_sphere(i) = dl_sphere(i)/length_scale + end do + + thetat(1) = 0. ! this defines the x direction, cell center 1 -> +! thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line + do i=2,n-1 + thetat(i) = thetat(i-1) + thetav(i-1) + end do + + do i=1,n-1 + xp(i) = cos(thetat(i)) * dl_sphere(i) + yp(i) = sin(thetat(i)) * dl_sphere(i) + end do + + else ! On an x-y plane + + theta_abs(iCell) = 0.0 + + xp(1) = xCell(iCell) + yp(1) = yCell(iCell) + + do i=2,n + iv = verticesOnCell(i-1,iCell) + xp(i) = xVertex(iv) + yp(i) = yVertex(iv) + end do + + end if + +! thetat(1) = 0. + thetat(1) = theta_abs(iCell) + do i=2,n-1 + ip1 = i+1 + if (ip1 == n) ip1 = 1 + thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & + xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, & + xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, & + 0.0_RKIND, 0.0_RKIND, 1.0_RKIND) + thetat(i) = thetat(i) + thetat(i-1) + end do + + area_cell = 0. + area_cellt = 0. + do i=1,n-1 + ip1 = i+1 + if (ip1 == n) ip1 = 1 + dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) + area_cell = area_cell + 0.25*(xp(i)+xp(ip1))*(yp(ip1)-yp(i)) - 0.25*(yp(i)+yp(ip1))*(xp(ip1)-xp(i)) + area_cellt = area_cellt + (0.25*(xp(i)+xp(ip1))*cos(thetat(i)) + 0.25*(yp(i)+yp(ip1))*sin(thetat(i)))*dl + end do + if (debug) write(0,*) ' area_cell, area_cellt ',area_cell, area_cellt,area_cell-area_cellt + + do i=1,n-1 + ip1 = i+1 + if (ip1 == n) ip1 = 1 + dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) + sint2 = (sin(thetat(i)))**2 + cost2 = (cos(thetat(i)))**2 + sint_cost = sin(thetat(i))*cos(thetat(i)) + defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell + defc_b(i,iCell) = dl*2.*sint_cost/area_cell + if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then + defc_a(i,iCell) = - defc_a(i,iCell) + defc_b(i,iCell) = - defc_b(i,iCell) + end if + + end do + + end do + + if (debug) write(0,*) ' exiting def weight calc ' + + end subroutine atm_initialize_deformation_weights + +end module atm_advection diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index a8ea9e9fee..69f46531c6 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -9,7 +9,6 @@ module init_atm_cases use mpas_kind_types use mpas_grid_types - use mpas_configure use mpas_constants use mpas_dmpar use atm_advection @@ -29,7 +28,7 @@ module init_atm_cases contains - subroutine init_atm_setup_case(domain) + subroutine init_atm_setup_case(domain, stream_manager) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Configure grid metadata and model state for the hydrostatic test case ! specified in the namelist @@ -38,13 +37,35 @@ subroutine init_atm_setup_case(domain) ! initialized !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use mpas_stream_manager + implicit none type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + integer :: i type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: fg + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: diag_physics + + integer, pointer :: config_init_case + logical, pointer :: config_static_interp + logical, pointer :: config_met_interp + + character(len=StrKIND), pointer :: mminlu + + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: nVertLevels + + + call mpas_pool_get_config(domain % blocklist % configs, 'config_init_case', config_init_case) ! ! Do some quick checks to make sure compile options are compatible with the chosen test case @@ -79,23 +100,42 @@ subroutine init_atm_setup_case(domain) if (config_init_case == 3) write(0,*) ' normal-mode perturbation included ' block_ptr => domain % blocklist do while (associated(block_ptr)) + + call mpas_pool_get_config(block_ptr % configs, 'config_static_interp', config_static_interp) + call mpas_pool_get_config(block_ptr % configs, 'config_met_interp', config_met_interp) + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + write(0,*) ' calling test case setup ' - call init_atm_case_jw(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_init_case) - call decouple_variables(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag) + call init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, block_ptr % configs, config_init_case) + call decouple_variables(mesh, nCells, nVertLevels, state, diag) write(0,*) ' returned from test case setup ' block_ptr => block_ptr % next end do - else if ((config_init_case == 4) .or. (config_init_case ==5)) then + else if ((config_init_case == 4) .or. (config_init_case == 5)) then write(0,*) ' squall line - super cell test case ' if (config_init_case == 4) write(0,*) ' squall line test case' if (config_init_case == 5) write(0,*) ' supercell test case' block_ptr => domain % blocklist do while (associated(block_ptr)) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + write(0,*) ' calling test case setup ' - call init_atm_case_squall_line(domain % dminfo, block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_init_case) - call decouple_variables(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag) + call init_atm_case_squall_line(domain % dminfo, mesh, nCells, nVertLevels, state, diag, config_init_case) + call decouple_variables(mesh, nCells, nVertLevels, state, diag) write(0,*) ' returned from test case setup ' block_ptr => block_ptr % next end do @@ -105,18 +145,42 @@ subroutine init_atm_setup_case(domain) write(0,*) ' mountain wave test case ' block_ptr => domain % blocklist do while (associated(block_ptr)) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + write(0,*) ' calling test case setup ' - call init_atm_case_mtn_wave(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_init_case) - call decouple_variables(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag) + call init_atm_case_mtn_wave(domain % dminfo, mesh, nCells, nVertLevels, state, diag, block_ptr % configs, config_init_case) + call decouple_variables(mesh, nCells, nVertLevels, state, diag) write(0,*) ' returned from test case setup ' block_ptr => block_ptr % next end do else if (config_init_case == 7 ) then + write(0,*) ' real-data GFS test case ' block_ptr => domain % blocklist + do while (associated(block_ptr)) + + call mpas_pool_get_config(block_ptr % configs, 'config_static_interp', config_static_interp) + call mpas_pool_get_config(block_ptr % configs, 'config_met_interp', config_met_interp) + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + if (config_static_interp) then ! @@ -135,13 +199,27 @@ subroutine init_atm_setup_case(domain) call mpas_dmpar_abort(domain % dminfo) end if - call init_atm_static(block_ptr % mesh) - call init_atm_static_orogwd(block_ptr % mesh) - endif - call init_atm_case_gfs(block_ptr % mesh, block_ptr % fg, & - block_ptr % state % time_levs(1) % state, block_ptr % diag, & - block_ptr % diag_physics, config_init_case) - if (config_met_interp) call physics_initialize_real(block_ptr % mesh, block_ptr % fg, domain % dminfo) + call init_atm_static(mesh, block_ptr % dimensions, block_ptr % configs) + call init_atm_static_orogwd(mesh, block_ptr % dimensions, block_ptr % configs) + end if + + ! + ! If at this point the mminlu variable is blank, we assume that the static interp step was + ! not run, and that we are working with a static file created before there was a choice + ! of land use datasets; in this case, the dataset was almost necessarily USGS + ! + call mpas_pool_get_array(mesh, 'mminlu', mminlu) + if (len_trim(mminlu) == 0) then + write(0,*) '****************************************************************' + write(0,*) 'No information on land use dataset is available.' + write(0,*) 'Assume that we are using ''USGS''.' + write(0,*) '****************************************************************' + write(mminlu,'(a)') 'USGS' + end if + + call init_atm_case_gfs(block_ptr, mesh, nCells, nEdges, nVertLevels, fg, state, & + diag, diag_physics, config_init_case, block_ptr % dimensions, block_ptr % configs) + if (config_met_interp) call physics_initialize_real(mesh, fg, domain % dminfo, block_ptr % dimensions, block_ptr % configs) block_ptr => block_ptr % next end do @@ -151,8 +229,12 @@ subroutine init_atm_setup_case(domain) write(0,*) 'real-data surface (SST) update test case ' block_ptr => domain % blocklist do while (associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + ! Defined in mpas_init_atm_surface.F - call init_atm_case_sfc(domain, domain % dminfo, block_ptr % mesh,block_ptr % fg, block_ptr % state % time_levs(1) % state) + call init_atm_case_sfc(domain, domain % dminfo, stream_manager, mesh, fg, state, block_ptr % dimensions, block_ptr % configs) block_ptr => block_ptr % next end do @@ -168,40 +250,37 @@ subroutine init_atm_setup_case(domain) end if - ! Copy initialized state to all time levels - 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 - !initialization of surface input variables technically not needed to run our current set of !idealized test cases: if (config_init_case < 7) then block_ptr => domain % blocklist do while (associated(block_ptr)) - call physics_idealized_init(block_ptr % mesh, block_ptr % fg) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) + + call physics_idealized_init(mesh, fg) + block_ptr => block_ptr % next end do - endif + end if end subroutine init_atm_setup_case !---------------------------------------------------------------------------------------------------------- - subroutine init_atm_case_jw(grid, state, diag, test_case) + subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, 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 + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: test_case real (kind=RKIND), parameter :: u0 = 35.0 @@ -220,27 +299,29 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) 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 :: u, ru, w, rw, v + real (kind=RKIND), dimension(:,:), pointer :: rho, theta 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(grid % nVertLevels, grid % nCells) :: qsat, relhum - real (kind=RKIND),dimension(:,:,:),pointer:: scalars + integer, pointer :: 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(nVertLevels, nCells) :: 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 + integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, itr, itrp, cell1, cell2 + integer, pointer :: nz1, nCellsSolve, nEdges, maxEdges, nVertices !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 + integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, verticesOnEdge, cellsOnCell 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) :: 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 @@ -250,23 +331,24 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) 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(nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm + real (kind=RKIND), dimension(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), dimension(nVertLevels + 1 ) :: sh, zw, ah + real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm + real (kind=RKIND), dimension(nVertLevels ) :: eta, etav, teta, ppi, tt, temperature_1d - real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2, psurf + real (kind=RKIND) :: d1, d2, d3, cof1, cof2, psurf + real (kind=RKIND), pointer :: cf1, cf2, cf3 ! 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(nVertLevels) :: flux_zonal + real (kind=RKIND), dimension(nVertLevels + 1, nlat) :: zgrid_2d + real (kind=RKIND), dimension(nVertLevels, nlat) :: u_2d, pp_2d, rho_2d, qv_2d, etavs_2d, zz_2d + real (kind=RKIND), dimension(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 @@ -274,70 +356,126 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) ! logical, parameter :: moisture = .true. logical, parameter :: moisture = .false. + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + + real (kind=RKIND), dimension(:), pointer :: latCell, latVertex, lonVertex, latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: fEdge, fVertex + + real (kind=RKIND), pointer :: sphere_radius + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: config_coef_3rd_order + integer, pointer :: config_theta_adv_order + integer, pointer :: config_init_case + + + call mpas_pool_get_config(configs, 'config_init_case', config_init_case) + call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + + ! ! Scale all distances and areas from a unit sphere to one with radius sphere_radius ! - 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 - 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 + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + + xCell(:) = xCell(:) * sphere_radius + yCell(:) = yCell(:) * sphere_radius + zCell(:) = zCell(:) * sphere_radius + xVertex(:) = xVertex(:) * sphere_radius + yVertex(:) = yVertex(:) * sphere_radius + zVertex(:) = zVertex(:) * sphere_radius + xEdge(:) = xEdge(:) * sphere_radius + yEdge(:) = yEdge(:) * sphere_radius + zEdge(:) = zEdge(:) * sphere_radius + dvEdge(:) = dvEdge(:) * sphere_radius + dcEdge(:) = dcEdge(:) * sphere_radius + areaCell(:) = areaCell(:) * sphere_radius**2.0 + areaTriangle(:) = areaTriangle(:) * sphere_radius**2.0 + kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * sphere_radius**2.0 + + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + + call mpas_pool_get_dimension(mesh, 'nVertLevels', nz1) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) 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 + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zx', zx) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'hx', hx) + call mpas_pool_get_array(mesh, 'dss', dss) + + call mpas_pool_get_array(diag, 'exner_base', pb) + call mpas_pool_get_array(diag, 'rho_base', rb) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'theta_base', tb) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(diag, 'rtheta_base', rtb) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(diag, 'exner', p) + call mpas_pool_get_array(diag, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'surface_pressure', surface_pressure) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'v', v) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(state, 'theta_m', t) + call mpas_pool_get_array(state, 'scalars', scalars) + call mpas_pool_get_array(state, 'u', u) + call mpas_pool_get_array(state, 'w', w) + + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'latVertex', latVertex) + call mpas_pool_get_array(mesh, 'lonVertex', lonVertex) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) !.. 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 @@ -346,40 +484,40 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) surface_pressure(:) = 0.0 - call atm_initialize_advection_rk(grid) - call atm_initialize_deformation_weights(grid) + call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius ) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) - index_qv = state % index_qv + call mpas_pool_get_dimension(state, 'index_qv', index_qv) - xnutr = 0. - zd = 12000. + xnutr = 0.0 + zd = 12000.0 znut = eta_t - etavs = (1.-0.252)*pii/2. - r_earth = grid % sphere_radius + etavs = (1.0 - 0.252) * pii/2. + r_earth = sphere_radius omega_e = omega - p0 = 1.e+05 + p0 = 1.0e+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 iCell=1,nCells do k=1,nz - phi = grid % latCell % array (iCell) + phi = latCell(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 + end do + end do ! Metrics for hybrid coordinate and vertical stretching - str = 1.8 + str = 1.5 zt = 45000. dz = zt/float(nz1) @@ -442,11 +580,7 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) 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 iCell=1,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 @@ -456,14 +590,14 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) end do end do - do i=1, grid % nEdges - iCell1 = grid % CellsOnEdge % array(1,i) - iCell2 = grid % CellsOnEdge % array(2,i) + do i=1, nEdges + iCell1 = cellsOnEdge(1,i) + iCell2 = cellsOnEdge(2,i) do k=1,nz - zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i) + zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / dcEdge(i) end do end do - do i=1, grid % nCells + do i=1, nCells do k=1,nz1 ztemp = .5*(zgrid(k+1,i)+zgrid(k,i)) dss(k,i) = 0. @@ -472,15 +606,15 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2 end if end do - enddo + end do !do k=1,nz1 ! write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1) - !enddo + !end do !do k=1,nz1 ! write(0,*) ' k, zx(k,1) ',k,zx(k,1) - !enddo + !end do write(0,*) ' grid metrics setup complete ' @@ -600,8 +734,8 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) end do 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,grid%sphere_radius) + 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, sphere_radius) end if @@ -612,7 +746,7 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) ! ! reference sounding based on dry isothermal atmosphere ! - do i=1, grid % nCells + do i=1, nCells do k=1,nz1 ztemp = .5*(zgrid(k+1,i)+zgrid(k,i)) ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b)) @@ -628,7 +762,7 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) ! 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 do ! end if 200 format(4i6,8(1x,e15.8)) @@ -649,7 +783,7 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5 end if end do - phi = grid % latCell % array (i) + phi = latCell(i) do k=1,nz1 temperature_1d(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) & *sqrt(cos(etav(k)))* & @@ -673,7 +807,7 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) relhum(k,i) = 1.0 else relhum(k,i) = (1.-((p0-ptemp)/50000.)**1.25) - endif + end if relhum(k,i) = min(rh_max,relhum(k,i)) !.. calculation of water vapor mixing ratio: @@ -738,79 +872,79 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) !write(0,*) !write(0,*) '--- initialization of water vapor:' - !do iCell = 1, grid % nCells - ! if(iCell == 1 .or. iCell == grid % nCells) then + !do iCell = 1, nCells + ! if(iCell == 1 .or. iCell == 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 + ! end do ! write(0,*) - ! endif - !enddo + ! end if + !end do lat_pert = latitude_pert*pii/180. lon_pert = longitude_pert*pii/180. - do iEdge=1,grid % nEdges + do iEdge=1,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))) * grid % sphere_radius / grid % dvEdge % array(iEdge) + vtx1 = verticesOnEdge(1,iEdge) + vtx2 = verticesOnEdge(2,iEdge) + lat1 = latVertex(vtx1) + lat2 = latVertex(vtx2) + iCell1 = cellsOnEdge(1,iEdge) + iCell2 = cellsOnEdge(2,iEdge) + flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1))) * sphere_radius / dvEdge(iEdge) if (config_init_case == 2) then - r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), & + r_pert = sphere_distance( latEdge(iEdge), lonEdge(iEdge), & lat_pert, lon_pert, 1.0_RKIND)/(pert_radius) - u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1) * grid % sphere_radius / grid % dvEdge % array(iEdge) + u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1) * sphere_radius / dvEdge(iEdge) else if (config_init_case == 3) then - lon_Edge = grid % lonEdge % array(iEdge) + lon_Edge = lonEdge(iEdge) u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) & - *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1))) * grid % sphere_radius / grid % dvEdge % array(iEdge) + *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1))) * sphere_radius / dvEdge(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),grid%sphere_radius,u0,nz1,nlat) - do k=1,grid % nVertLevels + call init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,dvEdge(iEdge),sphere_radius,u0,nz1,nlat) + do k=1,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 + u(k,iEdge) = fluxk + u_pert end do else - do k=1,grid % nVertLevels + do k=1,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 + u(k,iEdge) = fluxk + u_pert end do end if - cell1 = grid % CellsOnEdge % array(1,iEdge) - cell2 = grid % CellsOnEdge % array(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(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) + ru(k,iEdge) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*u(k,iEdge) end do ! ! Generate rotated Coriolis field ! - 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) & + fEdge(iEdge) = 2.0 * omega_e * & + ( -cos(lonEdge(iEdge)) * cos(latEdge(iEdge)) * sin(alpha_grid) + & + sin(latEdge(iEdge)) * cos(alpha_grid) & ) end do - do iVtx=1,grid % nVertices - 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) & + do iVtx=1,nVertices + fVertex(iVtx) = 2.0 * omega_e * & + (-cos(lonVertex(iVtx)) * cos(latVertex(iVtx)) * sin(alpha_grid) + & + sin(latVertex(iVtx)) * cos(alpha_grid) & ) end do @@ -821,11 +955,11 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) ! ! pre-calculation z-metric terms in omega eqn. ! - do iEdge = 1,grid % nEdges - cell1 = CellsOnEdge(1,iEdge) - cell2 = CellsOnEdge(2,iEdge) + do iEdge = 1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do k = 1, grid%nVertLevels + do k = 1, nVertLevels if (config_theta_adv_order == 2) then @@ -838,54 +972,54 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) ! 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)) + do i=1, nEdgesOnCell(cell1) + if ( cellsOnCell(i,cell1) > 0) & + d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,cellsOnCell(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)) + do i=1, nEdgesOnCell(cell2) + if ( cellsOnCell(i,cell2) > 0) & + d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,cellsOnCell(i,cell2)) end do z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) & - - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. + - (dcEdge(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. + z_edge3 = - (dcEdge(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) + 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 + rw = 0.0 + w = 0.0 + do iEdge = 1,nEdges - cell1 = CellsOnEdge(1,iEdge) - cell2 = CellsOnEdge(2,iEdge) + 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 + do k = 2, nVertLevels + flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge)) + rw(k,cell2) = rw(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux + rw(k,cell1) = rw(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* & + rw(k,cell2) = rw(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,diag % ru % array(k,iEdge))*config_coef_3rd_order* & + rw(k,cell1) = rw(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 @@ -894,10 +1028,9 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) 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)) + do iCell=1,nCells + do k=2,nVertLevels + w(k,iCell) = rw(k,iCell) / (fzp(k) * rho_zz(k-1,iCell) + fzm(k) * rho_zz(k,iCell)) end do end do @@ -905,12 +1038,12 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) ! ! 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 + v(:,:) = 0.0 + do iEdge = 1, 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) + do k = 1, nVertLevels + v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe) end do end do end do @@ -922,14 +1055,14 @@ subroutine init_atm_case_jw(grid, state, diag, test_case) *(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 + write(0,*) ' i, psurf, lat ',i,psurf,latCell(i)*180./3.1415828 + 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)) + do iCell=1,nCells + do k=1,nVertLevels + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + theta(k,iCell) = t(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell)) end do end do @@ -938,154 +1071,155 @@ end subroutine init_atm_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 - 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 - + 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 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,rad) - 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, 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) :: omega_e - - real (kind=RKIND) :: rdx, qtot, r_earth, phi - integer :: k,i, itr - - r_earth = rad - omega_e = omega - 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 + 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, 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) :: omega_e + + real (kind=RKIND) :: rdx, qtot, r_earth, phi + integer :: k,i, itr + + r_earth = rad + omega_e = omega + 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(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 + u_2d(k,i) = (3.*u_2d(k,i+1)-u_2d(k,i+2))*.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) + i=nlat 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)) + u_2d(k,i) = (3.*u_2d(k,i-1)-u_2d(k,i-2))*.5 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 init_atm_recompute_geostrophic_wind - subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) + subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, diag, test_case) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup squall line and supercell test case !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1093,110 +1227,164 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, 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 + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_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 + real (kind=RKIND), dimension(:,:,:), pointer :: 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 + integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge 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 + integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 + integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve + integer, pointer :: 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(nVertLevels + 1 ) :: znu, znw, znwc, znwv + real (kind=RKIND), dimension(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(nVertLevels + 1 ) :: zc, zw, ah + real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm - real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh, thi, tbi, cqwb + real (kind=RKIND), dimension(nVertLevels, 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), dimension(nVertLevels ) :: qvb + real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d - real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2 + real (kind=RKIND) :: d1, d2, d3, cof1, cof2 + real (kind=RKIND), pointer :: cf1, cf2, cf3 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 + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + + real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta + real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex + + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + ! ! 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 + xCell(:) = xCell(:) * a_scale + yCell(:) = yCell(:) * a_scale + zCell(:) = zCell(:) * a_scale + xVertex(:) = xVertex(:) * a_scale + yVertex(:) = yVertex(:) * a_scale + zVertex(:) = zVertex(:) * a_scale + xEdge(:) = xEdge(:) * a_scale + yEdge(:) = yEdge(:) * a_scale + zEdge(:) = zEdge(:) * a_scale + dvEdge(:) = dvEdge(:) * a_scale + dcEdge(:) = dcEdge(:) * a_scale + areaCell(:) = areaCell(:) * a_scale**2.0 + areaTriangle(:) = areaTriangle(:) * a_scale**2.0 + kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) + nz1 = 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 mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zx', zx) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'hx', hx) + call mpas_pool_get_array(mesh, 'dss', dss) + call mpas_pool_get_array(mesh, 't_init', t_init) + call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 'qv_init', qv_init) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + + call mpas_pool_get_array(diag, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'exner_base', pb) + call mpas_pool_get_array(diag, 'rho_base', rb) + call mpas_pool_get_array(diag, 'theta_base', tb) + call mpas_pool_get_array(diag, 'rtheta_base', rtb) + call mpas_pool_get_array(diag, 'exner', p) + call mpas_pool_get_array(diag, 'cqw', cqw) + + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'v', v) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'theta', theta) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(state, 'theta_m', t) + call mpas_pool_get_array(state, 'u', u) + call mpas_pool_get_array(state, 'w', w) + call mpas_pool_get_array(state, 'scalars', scalars) + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call atm_initialize_advection_rk(grid) - call atm_initialize_deformation_weights(grid) + scalars(:,:,:) = 0. + call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius ) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + xnutr = 0. zd = 12000. @@ -1209,11 +1397,11 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) ! We may pass in an hx(:,:) that has been precomputed elsewhere. ! For now it is independent of k - do iCell=1,grid % nCells + do iCell=1,nCells do k=1,nz hx(k,iCell) = 0. ! squall line or supercell on flat plane - enddo - enddo + end do + end do ! metrics for hybrid coordinate and vertical stretching @@ -1279,11 +1467,7 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) ! 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 iCell=1,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) @@ -1293,14 +1477,14 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) end do end do - do i=1, grid % nEdges - iCell1 = grid % CellsOnEdge % array(1,i) - iCell2 = grid % CellsOnEdge % array(2,i) + do i=1, nEdges + iCell1 = cellsOnEdge(1,i) + iCell2 = cellsOnEdge(2,i) do k=1,nz - zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i) + zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / dcEdge(i) end do end do - do i=1, grid % nCells + do i=1, nCells do k=1,nz1 ztemp = .5*(zgrid(k+1,i)+zgrid(k,i)) dss(k,i) = 0. @@ -1309,7 +1493,7 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2 end if end do - enddo + end do ! ! convective initialization @@ -1321,17 +1505,17 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) ! write(0,*) ' rgas, cp, gravity ',rgas,cp, gravity - if ( config_init_case == 4) then ! squall line parameters + if ( test_case == 4) then ! squall line parameters um = 12. us = 10. zts = 2500. - else if (config_init_case == 5) then !supercell parameters + else if (test_case == 5) then !supercell parameters um = 30. us = 15. zts = 5000. end if - do i=1,grid % nCells + do i=1,nCells do k=1,nz1 ztemp = .5*(zgrid(k,i)+zgrid(k+1,i)) if(ztemp .gt. ztr) then @@ -1354,9 +1538,9 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) ! 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) + do i=1, nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(2,i) if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then do k=1,nz1 ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) & @@ -1366,13 +1550,13 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) 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) + if(i == 1 ) u_init(k) = u(k,i) - us + u(k,i) = cos(angleEdge(i)) * (u(k,i) - us) end do end if end do - call mpas_dmpar_bcast_reals(dminfo, nz1, grid % u_init % array) + call mpas_dmpar_bcast_reals(dminfo, nz1, u_init) ! ! for reference sounding @@ -1398,7 +1582,7 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) ptopb = p0*pibtop**(1./rcp) write(6,*) 'ptopb = ',.01*ptopb - do i=1, grid % nCells + do i=1, 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 @@ -1418,7 +1602,7 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) ! ! update water vapor mixing ratio from humidity profile ! - do i= 1,grid%nCells + do i= 1,nCells do k=1,nz1 temp = p(k,i)*thi(k,i) pres = p0*p(k,i)**(1./rcp) @@ -1437,7 +1621,7 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) !********************************************************************* end do - do i= 1,grid%nCells + do i= 1,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)) @@ -1452,7 +1636,7 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) write(0,*) ' base state sounding ' write(0,*) ' k, pb, rb, tb, rtb, t, rr, p, qvb' - do k=1,grid%nVertLevels + do k=1,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 @@ -1466,23 +1650,23 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) radz = 1500. zcent = 1500. - if (config_init_case == 4) then ! squall line prameters - call mpas_dmpar_max_real(dminfo, maxval(grid % xCell % array(:)), xmid) + if (test_case == 4) then ! squall line prameters + call mpas_dmpar_max_real(dminfo, maxval(xCell(:)), xmid) xmid = xmid * 0.5 ymid = 0.0 ! Not used for squall line - else if (config_init_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) + else if (test_case == 5) then ! supercell parameters + call mpas_dmpar_max_real(dminfo, maxval(xCell(:)), xmid) + call mpas_dmpar_max_real(dminfo, maxval(yCell(:)), ymid) xmid = xmid * 0.5 ymid = ymid * 0.5 end if - do i=1, grid % nCells - xloc = grid % xCell % array(i) - xmid - if (config_init_case == 4) then + do i=1, nCells + xloc = xCell(i) - xmid + if (test_case == 4) then yloc = 0. !squall line setting - else if (config_init_case == 5) then - yloc = grid % yCell % array(i) - ymid !supercell setting + else if (test_case == 5) then + yloc = yCell(i) - ymid !supercell setting end if do k = 1,nz1 @@ -1508,7 +1692,7 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) call mpas_dmpar_bcast_real(dminfo, ptop) - do i = 1, grid % nCells + do i = 1, nCells pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* & (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i)) @@ -1540,23 +1724,23 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) !---------------------------------------------------------------------- ! do k=1,nz1 - grid % qv_init % array(k) = scalars(index_qv,k,1) + qv_init(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) + call mpas_dmpar_bcast_reals(dminfo, nz1, qv_init) - do i=1,grid % ncells + do i=1,nCells do k=1,nz1 - grid % t_init % array(k,i) = t_init_1d(k) + t_init(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) + do i=1,nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(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) @@ -1569,48 +1753,48 @@ subroutine init_atm_case_squall_line(dminfo, grid, state, diag, test_case) ! we are assuming w and rw are zero for this initialization ! i.e., no terrain ! - diag % rw % array = 0. - state % w % array = 0. + rw = 0.0 + w = 0.0 - grid % zb % array = 0. - grid % zb3% array = 0. + zb = 0.0 + zb3 = 0.0 ! ! Generate rotated Coriolis field ! - do iEdge=1,grid % nEdges - grid % fEdge % array(iEdge) = 0. + do iEdge=1,nEdges + fEdge(iEdge) = 0.0 end do - do iVtx=1,grid % nVertices - grid % fVertex % array(iVtx) = 0. + do iVtx=1,nVertices + fVertex(iVtx) = 0.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 + v(:,:) = 0.0 + do iEdge = 1, 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) + do k = 1, nVertLevels + v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(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) + ! do k=1,nVertLevels + ! write(0,'(i2,3(2x,f14.10)') k,u_init(k),t_initk),qv_init(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)) + do iCell=1,nCells + do k=1,nVertLevels + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + theta(k,iCell) = t(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell)) end do end do @@ -1620,16 +1804,20 @@ end subroutine init_atm_case_squall_line !---------------------------------------------------------------------------------------------------------- - subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) + subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag, configs, init_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 (dm_info), intent(in) :: dminfo + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: configs integer, intent(in) :: init_case real (kind=RKIND), parameter :: t0=288., hm=250. @@ -1641,109 +1829,158 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) !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 + integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, cellsOnCell 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 + integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, itr, itrp, cell1, cell2, nz1 + integer, pointer :: nEdges, maxEdges, nCellsSolve, nVertices + integer, pointer :: 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), dimension(nVertLevels, 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), dimension(nVertLevels + 1 ) :: zc, zw, ah + real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm - real (kind=RKIND) :: d1, d2, d3, cof1, cof2, cf1, cf2, cf3 + real (kind=RKIND) :: d1, d2, d3, cof1, cof2 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 + integer, dimension(nCells, 2) :: next_cell + real (kind=RKIND), dimension(nCells) :: hxzt logical, parameter :: terrain_smooth = .false. + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), pointer :: config_coef_3rd_order + integer, pointer :: config_theta_adv_order + + real (kind=RKIND), pointer :: cf1, cf2, cf3 + + real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta + real (kind=RKIND), dimension(:), pointer :: u_init, angleEdge, fEdge, fVertex + + + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + + call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 't_init', t_init) + call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + ! ! 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 + xCell(:) = xCell(:) * a_scale + yCell(:) = yCell(:) * a_scale + zCell(:) = zCell(:) * a_scale + xVertex(:) = xVertex(:) * a_scale + yVertex(:) = yVertex(:) * a_scale + zVertex(:) = zVertex(:) * a_scale + xEdge(:) = xEdge(:) * a_scale + yEdge(:) = yEdge(:) * a_scale + zEdge(:) = zEdge(:) * a_scale + dvEdge(:) = dvEdge(:) * a_scale + dcEdge(:) = dcEdge(:) * a_scale + areaCell(:) = areaCell(:) * a_scale**2.0 + areaTriangle(:) = areaTriangle(:) * a_scale**2.0 + kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + - nz1 = grid % nVertLevels + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) + nz1 = 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 + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zx', zx) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'hx', hx) + call mpas_pool_get_array(mesh, 'dss', dss) + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + + call mpas_pool_get_array(diag, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'exner_base', pb) + call mpas_pool_get_array(diag, 'rho_base', rb) + call mpas_pool_get_array(diag, 'theta_base', tb) + call mpas_pool_get_array(diag, 'rtheta_base', rtb) + call mpas_pool_get_array(diag, 'exner', p) + call mpas_pool_get_array(diag, 'cqw', cqw) + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'v', v) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'theta', theta) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(state, 'theta_m', t) + call mpas_pool_get_array(state, 'u', u) + call mpas_pool_get_array(state, 'w', w) + call mpas_pool_get_array(state, 'scalars', scalars) + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) scalars(:,:,:) = 0. - call atm_initialize_advection_rk(grid) - call atm_initialize_deformation_weights(grid) + call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius ) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) xnutr = 0.1 zd = 10500. @@ -1755,7 +1992,7 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) ! for hx computation xa = 5000. !SHP - should be changed based on grid distance xla = 4000. - xc = maxval (grid % xCell % array(:))/2. + xc = maxval (xCell(:))/2. ! metrics for hybrid coordinate and vertical stretching str = 1.0 @@ -1818,13 +2055,9 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) 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) + do iCell=1,nCells + xi = xCell(iCell) !====1. for pure cosine mountain ! if(abs(xi-xc).ge.2.*xa) then ! hx(1,iCell) = 0. @@ -1845,22 +2078,22 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) hx(nz,iCell) = zt !***** SHP -> get the temporary point information for the neighbor cell ->> should be changed!!!!! - do i=1,grid % nCells + do i=1,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 + !IF(yCell(i).eq.yCell(iCell).and.xCell(i).eq.xCell(iCell)-sqrt(3.)*dcEdge(1)) next_cell(iCell,1) = i + !IF(yCell(i).eq.yCell(iCell).and.xCell(i).eq.xCell(iCell)+sqrt(3.)*dcEdge(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 + if (xCell(iCell).le. 3.*dcEdge(1)) then next_cell(iCell,1) = 1 - else if (xCell(iCell).ge. maxval(xCell(:))-3.*grid % dcEdge % array(1)) then + else if (xCell(iCell).ge. maxval(xCell(:))-3.*dcEdge(1)) then next_cell(iCell,2) = 1 end if end do - enddo + end do write(0,*) ' hx computation complete ' @@ -1870,10 +2103,10 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) write(0,*) 'Otherwise, set terrain_smooth=.false. in the mountain wave test case' write(0,*) ' initialization routine and re-compile.' write(0,*) '***************************************************************************' - call mpas_dmpar_abort(grid % block % domain % dminfo) + call mpas_dmpar_abort(dminfo) end if - do iCell=1,grid % nCells + do iCell=1,nCells do k=1,nz if (terrain_smooth) then zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) & @@ -1888,14 +2121,14 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) end do end do - do i=1, grid % nEdges - iCell1 = grid % CellsOnEdge % array(1,i) - iCell2 = grid % CellsOnEdge % array(2,i) + do i=1, nEdges + iCell1 = cellsOnEdge(1,i) + iCell2 = cellsOnEdge(2,i) do k=1,nz - zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i) + zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / dcEdge(i) end do end do - do i=1, grid % nCells + do i=1, nCells do k=1,nz1 ztemp = .5*(zgrid(k+1,i)+zgrid(k,i)) dss(k,i) = 0. @@ -1904,7 +2137,7 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2 end if end do - enddo + end do write(0,*) ' grid metrics setup complete ' @@ -1923,7 +2156,7 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) um = 10. us = 0. - do i=1,grid % nCells + do i=1,nCells do k=1,nz1 ztemp = .5*(zgrid(k,i)+zgrid(k+1,i)) tb(k,i) = t0*(1. + xn2m/gravity*ztemp) @@ -1938,19 +2171,19 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) ! 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) + do i=1, nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(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 + if(i == 1 ) u_init(k) = u(k,i) - us #ifdef ROTATED_GRID - u(k,i) = sin(grid % angleEdge % array(i)) * (u(k,i) - us) + u(k,i) = sin(angleEdge(i)) * (u(k,i) - us) #else - u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us) + u(k,i) = cos(angleEdge(i)) * (u(k,i) - us) #endif end do end if @@ -1967,7 +2200,7 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) pitop = pitop-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1)) ptopb = p0*pitop**(1./rcp) - do i=1, grid % nCells + do i=1, 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 @@ -1986,7 +2219,7 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) write(0,*) ' ***** base state sounding ***** ' write(0,*) 'k pb p rb rtb rr tb t' - do k=1,grid%nVertLevels + do k=1,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 @@ -2004,7 +2237,7 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) 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 + do i = 1, nCells pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* & (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i)) @@ -2050,22 +2283,22 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) .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) + u_init(k), rr(k,1) end do - do i=1,grid % ncells + do i=1,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) + t_init(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) + do i=1,nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(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) @@ -2076,12 +2309,12 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) ! ! pre-calculation z-metric terms in omega eqn. ! - do iEdge = 1,grid % nEdges - cell1 = CellsOnEdge(1,iEdge) - cell2 = CellsOnEdge(2,iEdge) + do iEdge = 1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - do k = 1, grid%nVertLevels + do k = 1, nVertLevels if (config_theta_adv_order == 2) then @@ -2091,30 +2324,30 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) 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)) + do i=1, nEdgesOnCell(cell1) + if ( cellsOnCell(i,cell1) > 0) & + d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,cellsOnCell(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)) + do i=1, nEdgesOnCell(cell2) + if ( cellsOnCell(i,cell2) > 0) & + d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,cellsOnCell(i,cell2)) end do z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) & - - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. + - (dcEdge(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. + z_edge3 = - (dcEdge(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) + 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 @@ -2122,29 +2355,29 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) end do ! for including terrain - state % w % array(:,:) = 0.0 - diag % rw % array(:,:) = 0.0 + w(:,:) = 0.0 + rw(:,:) = 0.0 ! ! calculation of omega, rw = zx * ru + zz * rw ! - do iEdge = 1,grid % nEdges + do iEdge = 1,nEdges - cell1 = CellsOnEdge(1,iEdge) - cell2 = CellsOnEdge(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - do k = 2, grid%nVertLevels + do k = 2, 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 + rw(k,cell2) = rw(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux + rw(k,cell1) = rw(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) & + rw(k,cell2) = rw(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) & + rw(k,cell1) = rw(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 @@ -2155,53 +2388,52 @@ subroutine init_atm_case_mtn_wave(grid, state, diag, init_case) 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)) + do iCell=1,nCells + do k=2,nVertLevels + w(k,iCell) = rw(k,iCell) / (fzp(k) * rho_zz(k-1,iCell) + fzm(k) * rho_zz(k,iCell)) end do end do - do iEdge=1,grid % nEdges - grid % fEdge % array(iEdge) = 0. + do iEdge=1,nEdges + fEdge(iEdge) = 0. end do - do iVtx=1,grid % nVertices - grid % fVertex % array(iVtx) = 0. + do iVtx=1,nVertices + fVertex(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 + v(:,:) = 0.0 + do iEdge = 1, 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) + do k = 1, nVertLevels + v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(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) +! do k=1,nVertLevels +! write(0,*) ' k,u_init, t_init, qv_init ',k,u_init(k),t_init(k),qv_init(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)) + do iCell=1,nCells + do k=1,nVertLevels + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + theta(k,iCell) = t(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell)) end do end do end subroutine init_atm_case_mtn_wave - subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) + subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, diag_physics, init_case, dims, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Real-data test case using GFS data !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2213,14 +2445,19 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) implicit none - type (mesh_type), intent(inout) :: grid - type (fg_type), intent(inout) :: fg - type (state_type), intent(inout) :: state - type (diag_type), intent(inout) :: diag - type (diag_physics_type), intent(inout):: diag_physics + type (block_type), intent(inout), target :: block + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nEdges + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: fg + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout):: diag_physics integer, intent(in) :: init_case + type (mpas_pool_type), intent(inout):: dims + type (mpas_pool_type), intent(inout):: configs - type (block_type), pointer :: block type (parallel_info), pointer :: parinfo type (dm_info), pointer :: dminfo @@ -2244,6 +2481,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) real (kind=RKIND), dimension(:), pointer :: vert_level, latPoints, lonPoints, ter 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 :: surface_pressure real (kind=RKIND), dimension(:), pointer :: destField1d real (kind=RKIND), dimension(:,:), pointer :: destField2d real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 @@ -2251,10 +2489,12 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two real (kind=RKIND) :: target_z - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve + integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, itr, itrp, cell1, cell2 + integer, pointer :: nCellsSolve, nz1 integer :: nInterpPoints, ndims integer :: nfglevels_actual + integer, pointer :: index_qv integer, dimension(5) :: interp_list real (kind=RKIND) :: maskval @@ -2266,11 +2506,12 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) integer :: eoe, j integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, edgesOnCell, cellsOnCell - real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, AreaCell + real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell real (kind=RKIND), dimension(:,:), pointer :: v real (kind=RKIND), dimension(:,:), pointer :: sorted_arr type (field1DReal), pointer :: tempField + type (field1DReal), pointer :: ter_field type (field1DReal), target :: tempFieldTarget real(kind=RKIND), dimension(:), pointer :: hs, hs1 @@ -2287,10 +2528,10 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) real (kind=RKIND), allocatable, dimension(:,:) :: rslab, maskslab integer, dimension(:), pointer :: mask_array - integer, dimension(grid % nEdges), target :: edge_mask + integer, dimension(nEdges), target :: edge_mask character (len=StrKIND) :: fname - real (kind=RKIND) :: u, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r + real (kind=RKIND) :: flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r real (kind=RKIND) :: lat, lon, x, y real (kind=RKIND) :: ptop, p0, phi @@ -2298,79 +2539,187 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str - real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv + real (kind=RKIND), dimension(nVertLevels, nCells) :: rel_hum, temperature, qv real (kind=RKIND) :: ptmp, es, rs, rgas_moist, qvs, xnutr, znut, ptemp, rcv 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(nVertLevels + 1) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm + real (kind=RKIND), dimension(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 + real (kind=RKIND), dimension(nVertLevels + 1) :: sh, zw, ah + real (kind=RKIND), dimension(nVertLevels) :: zu, dzw, rdzwp, rdzwm + real (kind=RKIND), dimension(nVertLevels) :: eta, etav, teta, ppi, tt - real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2, psurf + real (kind=RKIND) :: d1, d2, d3, cof1, cof2, psurf ! storage for (lat,z) arrays for zonal velocity calculation integer, parameter :: nlat=361 - real (kind=RKIND), dimension(grid % nVertLevels + 1) :: zz_1d, zgrid_1d, hx_1d - real (kind=RKIND), dimension(grid % nVertLevels) :: flux_zonal - real (kind=RKIND), dimension(nlat, grid % nVertLevels) :: u_2d, etavs_2d - real (kind=RKIND), dimension(grid % nVertLevels + 1) :: fsum + real (kind=RKIND), dimension(nVertLevels + 1) :: zz_1d, zgrid_1d, hx_1d + real (kind=RKIND), dimension(nVertLevels) :: flux_zonal + real (kind=RKIND), dimension(nlat, nVertLevels) :: u_2d, etavs_2d + real (kind=RKIND), dimension(nVertLevels + 1) :: fsum real (kind=RKIND), dimension(nlat) :: lat_2d real (kind=RKIND) :: dlat real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2 + character (len=StrKIND), pointer :: config_met_prefix + character (len=StrKIND), pointer :: config_start_time + logical, pointer :: config_met_interp + logical, pointer :: config_vertical_grid + integer, pointer :: config_nsmterrain + real (kind=RKIND), pointer :: config_ztop + integer, pointer :: config_nfglevels + integer, pointer :: config_nfgsoillevels + logical, pointer :: config_smooth_surfaces + integer, pointer :: config_theta_adv_order + real (kind=RKIND), pointer :: config_coef_3rd_order + + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: angleEdge + real (kind=RKIND), pointer :: cf1, cf2, cf3 + integer, dimension(:), pointer :: landmask + + real (kind=RKIND), dimension(:,:), pointer :: dzs_fg + real (kind=RKIND), dimension(:,:), pointer :: zs_fg + + real (kind=RKIND), dimension(:), pointer :: sst + real (kind=RKIND), dimension(:), pointer :: seaice + real (kind=RKIND), dimension(:), pointer :: xice + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta + real (kind=RKIND), dimension(:,:), pointer :: rho + real (kind=RKIND), dimension(:,:), pointer :: rh + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rw + real (kind=RKIND), dimension(:), pointer :: precipw + real (kind=RKIND), dimension(:,:), pointer :: uReconstructX + real (kind=RKIND), dimension(:,:), pointer :: uReconstructY + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZ + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal + real (kind=RKIND), dimension(:,:), pointer :: uReconstructMeridional + + real (kind=RKIND), dimension(:), pointer :: psfc + real (kind=RKIND), dimension(:), pointer :: skintemp + real (kind=RKIND), dimension(:), pointer :: snow + real (kind=RKIND), dimension(:), pointer :: snowc + real (kind=RKIND), dimension(:,:), pointer :: u_fg + real (kind=RKIND), dimension(:,:), pointer :: v_fg + real (kind=RKIND), dimension(:,:), pointer :: z_fg + real (kind=RKIND), dimension(:,:), pointer :: t_fg + real (kind=RKIND), dimension(:,:), pointer :: rh_fg + real (kind=RKIND), dimension(:,:), pointer :: gfs_z + real (kind=RKIND), dimension(:,:), pointer :: p_fg + real (kind=RKIND), dimension(:,:), pointer :: st_fg + real (kind=RKIND), dimension(:,:), pointer :: sm_fg + + call mpas_pool_get_config(configs, 'config_met_prefix', config_met_prefix) + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_met_interp', config_met_interp) + call mpas_pool_get_config(configs, 'config_vertical_grid', config_vertical_grid) + call mpas_pool_get_config(configs, 'config_nsmterrain', config_nsmterrain) + call mpas_pool_get_config(configs, 'config_ztop', config_ztop) + call mpas_pool_get_config(configs, 'config_nfglevels', config_nfglevels) + call mpas_pool_get_config(configs, 'config_nfgsoillevels', config_nfgsoillevels) + call mpas_pool_get_config(configs, 'config_smooth_surfaces', config_smooth_surfaces) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) - block => grid % block parinfo => block % parinfo dminfo => block % domain % dminfo - nEdgesOnCell => grid % nEdgesOnCell % 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 - - deriv_two => grid % deriv_two % array - zb => grid % zb % array - zb3 => grid % zb3% array - - 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 - ter => grid % ter % 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 - - scalars => state % scalars % array - - nz1 = grid % nVertLevels + call mpas_pool_get_field(mesh, 'ter', ter_field) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zx', zx) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'hx', hx) + call mpas_pool_get_array(mesh, 'ter', ter) + call mpas_pool_get_array(mesh, 'dss', dss) + + call mpas_pool_get_array(diag, 'exner_base', pb) + call mpas_pool_get_array(diag, 'rho_base', rb) + call mpas_pool_get_array(diag, 'theta_base', tb) + call mpas_pool_get_array(diag, 'rtheta_base', rtb) + call mpas_pool_get_array(diag, 'exner', p) + call mpas_pool_get_array(diag, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'pressure', pressure) + call mpas_pool_get_array(diag, 'surface_pressure', surface_pressure) + call mpas_pool_get_array(diag, 'rh', rh) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(state, 'theta_m', t) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(state, 'scalars', scalars) + call mpas_pool_get_array(state, 'u', u) + call mpas_pool_get_array(state, 'w', w) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag_physics, 'precipw', precipw) + call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + call mpas_pool_get_array(mesh, 'landmask', landmask) + + call mpas_pool_get_array(fg, 'dzs_fg', dzs_fg) + call mpas_pool_get_array(fg, 'zs_fg', zs_fg) + call mpas_pool_get_array(fg, 'sst', sst) + call mpas_pool_get_array(fg, 'xice', xice) + call mpas_pool_get_array(fg, 'seaice', seaice) + call mpas_pool_get_array(fg, 'st_fg', st_fg) + call mpas_pool_get_array(fg, 'sm_fg', sm_fg) + call mpas_pool_get_array(fg, 'psfc', psfc) + call mpas_pool_get_array(fg, 'skintemp', skintemp) + call mpas_pool_get_array(fg, 'snow', snow) + call mpas_pool_get_array(fg, 'snowc', snowc) + call mpas_pool_get_array(fg, 'u', u_fg) + call mpas_pool_get_array(fg, 'v', v_fg) + call mpas_pool_get_array(fg, 'z', z_fg) + call mpas_pool_get_array(fg, 't', t_fg) + call mpas_pool_get_array(fg, 'rh', rh_fg) + call mpas_pool_get_array(fg, 'gfs_z', gfs_z) + call mpas_pool_get_array(fg, 'p', p_fg) + + call mpas_pool_get_dimension(dims, 'nVertLevels', nz1) + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) nz = nz1 + 1 - nCellsSolve = grid % nCellsSolve + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) xnutr = 0. zd = 12000. @@ -2378,7 +2727,6 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) etavs = (1.-0.252)*pii/2. rcv = rgas/(cp-rgas) - r_earth = grid % sphere_radius omega_e = omega p0 = 1.e+05 @@ -2396,7 +2744,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) write(0,*) 'Error opening initial meteorological data file '// & trim(config_met_prefix)//':'//config_start_time(1:13) write(0,*) '********************************************************************************' - call mpas_dmpar_abort(grid % block % domain % dminfo) + call mpas_dmpar_abort(dminfo) end if call read_next_met_field(field, istatus) @@ -2420,9 +2768,9 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) if (index(field % field, 'SOILHGT') /= 0) then - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell destField1d => ter ndims = 1 end if @@ -2460,8 +2808,8 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! ! Vertical grid setup ! - allocate(hs (grid%nCells+1)) - allocate(hs1(grid%nCells+1)) + allocate(hs (nCells+1)) + allocate(hs1(nCells+1)) ! Fourth order smoother for terrain @@ -2469,7 +2817,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) do i=1,nsmterrain - do iCell=1,grid%nCells + do iCell=1,nCells hs(iCell) = 0. if(ter(iCell) .ne. 0.) then do j = 1,nEdgesOnCell(iCell) @@ -2477,11 +2825,11 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) / dcEdge(edgesOnCell(j,iCell)) & * (ter(cellsOnCell(j,iCell))-ter(iCell)) end do - endif + end if hs(iCell) = ter(iCell) + 0.125*hs(iCell) end do - do iCell=1,grid %nCells + do iCell=1,nCells ter(iCell) = 0. if(hs(iCell) .ne. 0.) then do j = 1,nEdgesOnCell(iCell) @@ -2489,17 +2837,17 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) / dcEdge(edgesOnCell(j,iCell)) & * (hs(cellsOnCell(j,iCell))-hs(iCell)) end do - endif + end if ! ter(iCell) = hs(iCell) - 0.25*ter(iCell) ter(iCell) = hs(iCell) - 0.125*ter(iCell) end do ! note that ther variable ter used throughout this section is a pointer to grid % ter % array, here we are passing ter's parent field - call mpas_dmpar_exch_halo_field(grid % ter) + call mpas_dmpar_exch_halo_field(ter_field) end do - do iCell=1,grid % nCells + do iCell=1,nCells hx(:,iCell) = ter(iCell) end do @@ -2590,10 +2938,6 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) write(0,*) ' cf1, cf2, cf3 = ',cf1,cf2,cf3 - grid % cf1 % scalar = cf1 - grid % cf2 % scalar = cf2 - grid % cf3 % scalar = cf3 - ! Smoothing algorithm for coordinate surfaces smooth = config_smooth_surfaces @@ -2612,7 +2956,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) sm = .02*min(0.5_RKIND*zw(k)/hm,1.0_RKIND) do i=1,30 - do iCell=1,grid % nCells + do iCell=1,nCells hs1(iCell) = 0. do j = 1,nEdgesOnCell(iCell) @@ -2634,7 +2978,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) tempField => tempFieldTarget tempField % block => block - tempField % dimSizes(1) = grid % nCells + tempField % dimSizes(1) = nCells tempField % sendList => parinfo % cellsToSend tempField % recvList => parinfo % cellsToRecv tempField % copyList => parinfo % cellsToCopy @@ -2675,7 +3019,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! Height of coordinate levels (calculation of zgrid) - do iCell=1,grid % nCells + do iCell=1,nCells do k=1,nz zgrid(k,iCell) = zw(k) + ah(k)*hx(k,iCell) end do @@ -2684,14 +3028,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) end do end do - do i=1, grid % nEdges - iCell1 = grid % CellsOnEdge % array(1,i) - iCell2 = grid % CellsOnEdge % array(2,i) + do i=1, nEdges + iCell1 = cellsOnEdge(1,i) + iCell2 = cellsOnEdge(2,i) do k=1,nz - zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i) + zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / dcEdge(i) end do end do - do i=1, grid % nCells + do i=1, nCells do k=1,nz1 ztemp = .5*(zgrid(k+1,i)+zgrid(k,i)) dss(k,i) = 0. @@ -2700,24 +3044,24 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2 end if end do - enddo + end do ! do k=1,nz1 ! write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1) -! enddo +! end do ! do k=1,nz1 ! write(0,*) ' k, zx(k,1) ',k,zx(k,1) -! enddo +! end do ! For z-metric term in omega equation - do iEdge = 1,grid % nEdges - cell1 = CellsOnEdge(1,iEdge) - cell2 = CellsOnEdge(2,iEdge) + do iEdge = 1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - do k = 1, grid%nVertLevels + do k = 1, nVertLevels if (config_theta_adv_order == 2) then @@ -2727,30 +3071,30 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) 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)) + do i=1, nEdgesOnCell(cell1) + if ( cellsOnCell(i,cell1) > 0) & + d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,cellsOnCell(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)) + do i=1, nEdgesOnCell(cell2) + if ( cellsOnCell(i,cell2) > 0) & + d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,cellsOnCell(i,cell2)) end do z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) & - - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. + - (dcEdge(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. + z_edge3 = - (dcEdge(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) + 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 @@ -2766,9 +3110,9 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) !ldf (2011-11-19): added initialization of the sea-surface temperature, seaice fraction, and !seaice flag: - fg % sst % array = 0. - fg % xice % array = 0. - fg % seaice % array = 0. + sst = 0.0 + xice = 0.0 + seaice = 0.0 !ldf end. ! @@ -2781,7 +3125,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) write(0,*) 'Error opening initial meteorological data file '// & trim(config_met_prefix)//':'//config_start_time(1:13) write(0,*) '********************************************************************************' - call mpas_dmpar_abort(grid % block % domain % dminfo) + call mpas_dmpar_abort(dminfo) end if call read_next_met_field(field, istatus) @@ -2823,7 +3167,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) write(0,*) 'Error opening initial meteorological data file '// & trim(config_met_prefix)//':'//config_start_time(1:13) write(0,*) '********************************************************************************' - call mpas_dmpar_abort(grid % block % domain % dminfo) + call mpas_dmpar_abort(dminfo) end if call read_next_met_field(field, istatus) @@ -2839,7 +3183,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) fillval = 0.0 msgval = -1.e30 - mask_array => grid % landmask % array + mask_array => landmask if (index(field % field, 'UU') /= 0 .or. & index(field % field, 'VV') /= 0 .or. & @@ -2854,11 +3198,19 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) index(field % field, 'SM040100') /= 0 .or. & index(field % field, 'SM100200') /= 0 .or. & index(field % field, 'SM010200') /= 0 .or. & + index(field % field, 'SM000007') /= 0 .or. & + index(field % field, 'SM007028') /= 0 .or. & + index(field % field, 'SM028100') /= 0 .or. & + index(field % field, 'SM100255') /= 0 .or. & index(field % field, 'ST000010') /= 0 .or. & index(field % field, 'ST010040') /= 0 .or. & index(field % field, 'ST040100') /= 0 .or. & index(field % field, 'ST100200') /= 0 .or. & index(field % field, 'ST010200') /= 0 .or. & + index(field % field, 'ST000007') /= 0 .or. & + index(field % field, 'ST007028') /= 0 .or. & + index(field % field, 'ST028100') /= 0 .or. & + index(field % field, 'ST100255') /= 0 .or. & index(field % field, 'PRES') /= 0 .or. & index(field % field, 'SNOW') /= 0 .or. & index(field % field, 'SEAICE') /= 0 .or. & @@ -2869,11 +3221,19 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) index(field % field, 'SM040100') /= 0 .or. & index(field % field, 'SM100200') /= 0 .or. & index(field % field, 'SM010200') /= 0 .or. & + index(field % field, 'SM000007') /= 0 .or. & + index(field % field, 'SM007028') /= 0 .or. & + index(field % field, 'SM028100') /= 0 .or. & + index(field % field, 'SM100255') /= 0 .or. & index(field % field, 'ST000010') /= 0 .or. & index(field % field, 'ST010040') /= 0 .or. & index(field % field, 'ST040100') /= 0 .or. & index(field % field, 'ST100200') /= 0 .or. & index(field % field, 'ST010200') /= 0 .or. & + index(field % field, 'ST000007') /= 0 .or. & + index(field % field, 'ST007028') /= 0 .or. & + index(field % field, 'ST028100') /= 0 .or. & + index(field % field, 'ST100255') /= 0 .or. & index(field % field, 'SNOW') /= 0 .or. & index(field % field, 'SEAICE') /= 0 .or. & index(field % field, 'SKINTEMP') /= 0) then @@ -2889,7 +3249,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) write(0,*) 'Error: The meteorological data file has more than config_nfglevels.' write(0,*) ' Please increase config_nfglevels in the namelist and re-run.' write(0,*) '*******************************************************************' - call mpas_dmpar_abort(grid % block % domain % dminfo) + call mpas_dmpar_abort(dminfo) end if if (vert_level(k) == -1.0) vert_level(k) = field % xlvl else @@ -2927,69 +3287,69 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) mask_array => edge_mask - nInterpPoints = grid % nEdges - latPoints => grid % latEdge % array - lonPoints => grid % lonEdge % array - destField2d => fg % u % array + nInterpPoints = nEdges + latPoints => latEdge + lonPoints => lonEdge + call mpas_pool_get_array(fg, 'u', destField2d) ndims = 2 else if (index(field % field, 'VV') /= 0) then write(0,*) 'Interpolating V at ', k, vert_level(k) mask_array => edge_mask - nInterpPoints = grid % nEdges - latPoints => grid % latEdge % array - lonPoints => grid % lonEdge % array - destField2d => fg % v % array + nInterpPoints = nEdges + latPoints => latEdge + lonPoints => lonEdge + call mpas_pool_get_array(fg, 'v', destField2d) ndims = 2 else if (index(field % field, 'TT') /= 0) then write(0,*) 'Interpolating T at ', k, vert_level(k) - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % t % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 't', destField2d) ndims = 2 else if (index(field % field, 'RH') /= 0) then write(0,*) 'Interpolating RH at ', k, vert_level(k) - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % rh % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'rh', destField2d) ndims = 2 else if (index(field % field, 'GHT') /= 0) then write(0,*) 'Interpolating GHT at ', k, vert_level(k) - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % z % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'z', destField2d) ndims = 2 else if (index(field % field, 'PRES') /= 0) then write(0,*) 'Interpolating PRES at ', k, vert_level(k) - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % p % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'p', destField2d) ndims = 2 else if (index(field % field, 'PMSL') /= 0) then write(0,*) 'Interpolating PMSL' - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField1d => fg % pmsl % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'pmsl', destField1d) ndims = 1 else if (index(field % field, 'PSFC') /= 0) then write(0,*) 'Interpolating PSFC' - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField1d => fg % psfc % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'psfc', destField1d) ndims = 1 else if (index(field % field, 'SOILHGT') /= 0) then write(0,*) 'Interpolating SOILHGT' - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField1d => fg % soilz % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'soilz', destField1d) ndims = 1 else if (index(field % field, 'SM000010') /= 0) then write(0,*) 'Interpolating SM000010' @@ -3003,14 +3363,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 1.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % sm_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) k = 1 ndims = 2 - fg % dzs_fg % array(k,:) = 10. - fg % zs_fg % array(k,:) = 10. + dzs_fg(k,:) = 10. + zs_fg(k,:) = 10. else if (index(field % field, 'SM010200') /= 0) then write(0,*) 'Interpolating SM010200' @@ -3023,14 +3383,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 1.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % sm_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) k = 2 ndims = 2 - fg % dzs_fg % array(k,:) = 200.-10. - fg % zs_fg % array(k,:) = 200. + dzs_fg(k,:) = 200.-10. + zs_fg(k,:) = 200. else if (index(field % field, 'SM010040') /= 0) then write(0,*) 'Interpolating SM010040' @@ -3043,14 +3403,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 1.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % sm_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) k = 2 ndims = 2 - fg % dzs_fg % array(k,:) = 40.-10. - fg % zs_fg % array(k,:) = 40. + dzs_fg(k,:) = 40.-10. + zs_fg(k,:) = 40. else if (index(field % field, 'SM040100') /= 0) then write(0,*) 'Interpolating SM040100' @@ -3063,14 +3423,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 1.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % sm_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) k = 3 ndims = 2 - fg % dzs_fg % array(k,:) = 100.-40. - fg % zs_fg % array(k,:) = 100. + dzs_fg(k,:) = 100.-40. + zs_fg(k,:) = 100. else if (index(field % field, 'SM100200') /= 0) then write(0,*) 'Interpolating SM100200' @@ -3083,14 +3443,94 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 1.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % sm_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) + k = 4 + ndims = 2 + dzs_fg(k,:) = 200.-100. + zs_fg(k,:) = 200. + else if (index(field % field, 'SM000007') /= 0) then +write(0,*) 'Interpolating SM000007' + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = SEARCH + interp_list(4) = 0 + + maskval = 0.0 + masked = 0 + fillval = 1.0 + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) + k = 1 + ndims = 2 + dzs_fg(k,:) = 7. + zs_fg(k,:) = 7. + else if (index(field % field, 'SM007028') /= 0) then +write(0,*) 'Interpolating SM007028' + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = SEARCH + interp_list(4) = 0 + + maskval = 0.0 + masked = 0 + fillval = 1.0 + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) + k = 2 + ndims = 2 + dzs_fg(k,:) = 28.-7. + zs_fg(k,:) = 28. + else if (index(field % field, 'SM028100') /= 0) then +write(0,*) 'Interpolating SM028100' + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = SEARCH + interp_list(4) = 0 + + maskval = 0.0 + masked = 0 + fillval = 1.0 + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) + k = 3 + ndims = 2 + dzs_fg(k,:) = 100.-28. + zs_fg(k,:) = 100. + else if (index(field % field, 'SM100255') /= 0) then +write(0,*) 'Interpolating SM100255' + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = SEARCH + interp_list(4) = 0 + + maskval = 0.0 + masked = 0 + fillval = 1.0 + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sm_fg', destField2d) k = 4 ndims = 2 - fg % dzs_fg % array(k,:) = 200.-100. - fg % zs_fg % array(k,:) = 200. + dzs_fg(k,:) = 255.-100. + zs_fg(k,:) = 255. else if (index(field % field, 'ST000010') /= 0) then write(0,*) 'Interpolating ST000010' @@ -3104,14 +3544,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 285.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % st_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) k = 1 ndims = 2 - fg % dzs_fg % array(k,:) = 10. - fg % zs_fg % array(k,:) = 10. + dzs_fg(k,:) = 10. + zs_fg(k,:) = 10. else if (index(field % field, 'ST010200') /= 0) then write(0,*) 'Interpolating ST010200' @@ -3125,14 +3565,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 285.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % st_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) k = 2 ndims = 2 - fg % dzs_fg % array(k,:) = 200.-10. - fg % zs_fg % array(k,:) = 200. + dzs_fg(k,:) = 200.-10. + zs_fg(k,:) = 200. else if (index(field % field, 'ST010040') /= 0) then write(0,*) 'Interpolating ST010040' @@ -3146,14 +3586,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 285.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % st_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) k = 2 ndims = 2 - fg % dzs_fg % array(k,:) = 40.-10. - fg % zs_fg % array(k,:) = 40. + dzs_fg(k,:) = 40.-10. + zs_fg(k,:) = 40. else if (index(field % field, 'ST040100') /= 0) then write(0,*) 'Interpolating ST040100' @@ -3167,14 +3607,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 285.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % st_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) k = 3 ndims = 2 - fg % dzs_fg % array(k,:) = 100.-40. - fg % zs_fg % array(k,:) = 100. + dzs_fg(k,:) = 100.-40. + zs_fg(k,:) = 100. else if (index(field % field, 'ST100200') /= 0) then write(0,*) 'Interpolating ST100200' @@ -3188,14 +3628,98 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 285.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField2d => fg % st_fg % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) k = 4 ndims = 2 - fg % dzs_fg % array(k,:) = 200.-100. - fg % zs_fg % array(k,:) = 200. + dzs_fg(k,:) = 200.-100. + zs_fg(k,:) = 200. + else if (index(field % field, 'ST000007') /= 0) then +write(0,*) 'Interpolating ST000007' + + interp_list(1) = SIXTEEN_POINT + interp_list(2) = FOUR_POINT + interp_list(3) = W_AVERAGE4 + interp_list(4) = SEARCH + interp_list(5) = 0 + + maskval = 0.0 + masked = 0 + fillval = 285.0 + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) + k = 1 + ndims = 2 + dzs_fg(k,:) = 7. + zs_fg(k,:) = 7. + else if (index(field % field, 'ST007028') /= 0) then +write(0,*) 'Interpolating ST007028' + + interp_list(1) = SIXTEEN_POINT + interp_list(2) = FOUR_POINT + interp_list(3) = W_AVERAGE4 + interp_list(4) = SEARCH + interp_list(5) = 0 + + maskval = 0.0 + masked = 0 + fillval = 285.0 + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) + k = 2 + ndims = 2 + dzs_fg(k,:) = 28.-7. + zs_fg(k,:) = 28. + else if (index(field % field, 'ST028100') /= 0) then +write(0,*) 'Interpolating ST028100' + + interp_list(1) = SIXTEEN_POINT + interp_list(2) = FOUR_POINT + interp_list(3) = W_AVERAGE4 + interp_list(4) = SEARCH + interp_list(5) = 0 + + maskval = 0.0 + masked = 0 + fillval = 285.0 + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) + k = 3 + ndims = 2 + dzs_fg(k,:) = 100.-28. + zs_fg(k,:) = 100. + else if (index(field % field, 'ST100255') /= 0) then +write(0,*) 'Interpolating ST100255' + + interp_list(1) = SIXTEEN_POINT + interp_list(2) = FOUR_POINT + interp_list(3) = W_AVERAGE4 + interp_list(4) = SEARCH + interp_list(5) = 0 + + maskval = 0.0 + masked = 0 + fillval = 285.0 + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'st_fg', destField2d) + k = 4 + ndims = 2 + dzs_fg(k,:) = 255.-100. + zs_fg(k,:) = 255. else if (index(field % field, 'SNOW') /= 0) then write(0,*) 'Interpolating SNOW' @@ -3206,10 +3730,10 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 0 fillval = 0.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField1d => fg % snow % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'snow', destField1d) ndims = 1 else if (index(field % field, 'SEAICE') /= 0) then write(0,*) 'Interpolating SEAICE' @@ -3223,17 +3747,17 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 1 fillval = 0.0 - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField1d => fg % xice % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'xice', destField1d) ndims = 1 else if (index(field % field, 'SKINTEMP') /= 0) then write(0,*) 'Interpolating SKINTEMP' - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField1d => fg % skintemp % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'skintemp', destField1d) ndims = 1 end if @@ -3280,41 +3804,41 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) call read_met_close() ! Fix for isobaric data - if (minval(fg % p % array(:,:)) == 0.0) then + if (minval(p_fg(:,:)) == 0.0) then write(0,*) 'Setting pressure field for isobaric data' do k=1,config_nfglevels if (vert_level(k) /= 200100.0) then - fg % p % array(k,:) = vert_level(k) + p_fg(k,:) = vert_level(k) else - fg % p % array(k,:) = fg % psfc % array(:) + p_fg(k,:) = psfc(:) end if end do end if ! Set SST based on SKINTEMP field if it wasn't found in input data - if (minval(fg % sst % array) == 0.0 .and. maxval(fg % sst % array) == 0.0) then + if (minval(sst) == 0.0 .and. maxval(sst) == 0.0) then write(0,*) 'Setting SST from SKINTEMP' - !where (grid % landmask % array == 0) fg % sst % array = fg % skintemp % array - fg % sst % array = fg % skintemp % array + !where (landmask == 0) sst = skintemp + sst = skintemp end if ! Set SNOWC (snow-cover flag) based on SNOW - fg % snowc % array(:) = 0.0 - where (fg % snow % array > 0.0) fg % snowc % array = 1.0 + snowc(:) = 0.0 + where (snow > 0.0) snowc = 1.0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !MGD CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -do iCell=1,grid%nCells - if (grid % landmask % array(iCell) == 1) then +do iCell=1,nCells + if (landmask(iCell) == 1) then do k = 1, config_nfgsoillevels - if (fg % st_fg % array(k,iCell) <= 0.0) write(0,*) 'Bad st_fg ', k, iCell - enddo + if (st_fg(k,iCell) <= 0.0) write(0,*) 'Bad st_fg ', k, iCell + end do do k = 1, config_nfgsoillevels - if (fg % sm_fg % array(k,iCell) <= 0.0) write(0,*) 'Bad sm_fg ', k, iCell - enddo + if (sm_fg(k,iCell) <= 0.0) write(0,*) 'Bad sm_fg ', k, iCell + end do !LDF end. end if @@ -3355,10 +3879,10 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) end if if (index(field % field, 'SEAICE') /= 0) then - nInterpPoints = grid % nCells - latPoints => grid % latCell % array - lonPoints => grid % lonCell % array - destField1d => fg % xice % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'xice', destField1d) ndims = 1 end if @@ -3369,7 +3893,7 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) masked = 1 fillval = 0.0 msgval = 1.01 - mask_array => grid % landmask % array + mask_array => landmask allocate(rslab(field % nx, field % ny)) @@ -3412,26 +3936,26 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) if (allocated(maskslab)) deallocate(maskslab) ! Freeze really cold ocean - where (fg % sst % array < 271.0 .and. grid % landmask % array == 0) fg % xice % array = 1.0 + where (sst < 271.0 .and. landmask == 0) xice = 1.0 ! Limit XICE to values between 0 and 1. Although the input meteorological field is between 0. ! and 1., interpolation to the MPAS grid can yield values of XiCE less than 0. and greater ! than 1.: - where (fg % xice % array < 0._RKIND) fg % xice % array = 0._RKIND - where (fg % xice % array > 1._RKIND) fg % xice % array = 1._RKIND + where (xice < 0._RKIND) xice = 0._RKIND + where (xice > 1._RKIND) xice = 1._RKIND ! Set SEAICE (0/1 flag) based on XICE (fractional ice coverage) - fg % seaice % array(:) = 0.0 - where (fg % xice % array >= 0.5) fg % seaice % array = 1.0 + seaice(:) = 0.0 + where (xice >= 0.5) seaice = 1.0 ! - ! Compute normal wind component and store in fg%u + ! Compute normal wind component and store in fg % u ! - do iEdge=1,grid%nEdges + do iEdge=1,nEdges do k=1,config_nfglevels - fg % u % array(k,iEdge) = cos(grid % angleEdge % array(iEdge)) * fg % u % array(k,iEdge) & - + sin(grid % angleEdge % array(iEdge)) * fg % v % array(k,iEdge) + u_fg(k,iEdge) = cos(angleEdge(iEdge)) * u_fg(k,iEdge) & + + sin(angleEdge(iEdge)) * v_fg(k,iEdge) end do end do @@ -3452,21 +3976,21 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! allocate(sorted_arr(2,nfglevels_actual)) - do iCell=1,grid%nCells + do iCell=1,nCells ! T sorted_arr(:,:) = -999.0 do k=1,nfglevels_actual - sorted_arr(1,k) = fg % z % array(k,iCell) + sorted_arr(1,k) = z_fg(k,iCell) !NOSFC if (vert_level(k) == 200100.0) sorted_arr(1,k) = fg % soilz % array(iCell) if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 - sorted_arr(2,k) = fg % t % array(k,iCell) + sorted_arr(2,k) = t_fg(k,iCell) end do call mpas_quicksort(nfglevels_actual, sorted_arr) - do k=1,grid%nVertLevels - target_z = 0.5 * (grid % zgrid % array(k,iCell) + grid % zgrid % array(k+1,iCell)) -! state % theta_m % array(k,iCell) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1) - state % theta_m % array(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & + do k=1,nVertLevels + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) +! t(k,iCell) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1) + t(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) end do @@ -3474,54 +3998,54 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! RH sorted_arr(:,:) = -999.0 do k=1,nfglevels_actual - sorted_arr(1,k) = fg % z % array(k,iCell) + sorted_arr(1,k) = z_fg(k,iCell) !NOSFC if (vert_level(k) == 200100.0) sorted_arr(1,k) = fg % soilz % array(iCell) if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 - sorted_arr(2,k) = fg % rh % array(k,iCell) + sorted_arr(2,k) = rh_fg(k,iCell) end do call mpas_quicksort(nfglevels_actual, sorted_arr) - do k=1,grid%nVertLevels - target_z = 0.5 * (grid % zgrid % array(k,iCell) + grid % zgrid % array(k+1,iCell)) -! state % scalars % array(state % index_qv,k,iCell) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=0) - state % scalars % array(state % index_qv,k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & + do k=1,nVertLevels + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) +! scalars(index_qv,k,iCell) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=0) + scalars(index_qv,k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) - diag % rh % array(k,iCell) = state % scalars % array(state % index_qv,k,iCell) + if (target_z < z_fg(1,iCell)) scalars(index_qv,k,iCell) = scalars(index_qv,k+1,iCell) + rh(k,iCell) = scalars(index_qv,k,iCell) end do ! GHT sorted_arr(:,:) = -999.0 do k=1,nfglevels_actual - sorted_arr(1,k) = fg % z % array(k,iCell) + sorted_arr(1,k) = z_fg(k,iCell) !NOSFC if (vert_level(k) == 200100.0) sorted_arr(1,k) = fg % soilz % array(iCell) if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 - sorted_arr(2,k) = fg % z % array(k,iCell) + sorted_arr(2,k) = z_fg(k,iCell) end do call mpas_quicksort(nfglevels_actual, sorted_arr) - do k=1,grid%nVertLevels - target_z = 0.5 * (grid % zgrid % array(k,iCell) + grid % zgrid % array(k+1,iCell)) -! fg % gfs_z % array(k,iCell) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1) - fg % gfs_z % array(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & - sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) + do k=1,nVertLevels + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) +! gfs_z(k,iCell) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1) + gfs_z(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) end do ! PRESSURE sorted_arr(:,:) = -999.0 do k=1,nfglevels_actual - sorted_arr(1,k) = fg % z % array(k,iCell) + sorted_arr(1,k) = z_fg(k,iCell) if (vert_level(k) == 200100.0) then !NOSFC sorted_arr(1,k) = fg % soilz % array(iCell) sorted_arr(1,k) = 99999.0 sfc_k = k end if - sorted_arr(2,k) = log(fg % p % array(k,iCell)) + sorted_arr(2,k) = log(p_fg(k,iCell)) end do call mpas_quicksort(nfglevels_actual, sorted_arr) - do k=1,grid%nVertLevels - target_z = 0.5 * (grid % zgrid % array(k,iCell) + grid % zgrid % array(k+1,iCell)) -! diag % pressure % array(k,iCell) = exp(vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1)) - diag % pressure % array(k,iCell) = exp(vertical_interp(target_z, nfglevels_actual-1, & + do k=1,nVertLevels + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) +! pressure(k,iCell) = exp(vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1)) + pressure(k,iCell) = exp(vertical_interp(target_z, nfglevels_actual-1, & sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1)) end do @@ -3529,39 +4053,38 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! PRESSURE ! sorted_arr(:,:) = -999.0 ! do k=1,nfglevels_actual -! sorted_arr(1,k) = fg % z % array(k,iCell) +! sorted_arr(1,k) = z_fg(k,iCell) ! if (vert_level(k) == 200100.0) then !!NOSFC sorted_arr(1,k) = fg % soilz % array(iCell) ! sorted_arr(1,k) = 99999.0 ! sfc_k = k ! end if -! sorted_arr(2,k) = log(fg % p % array(k,iCell)) +! sorted_arr(2,k) = log(p_fg(k,iCell)) ! end do ! call mpas_quicksort(nfglevels_actual, sorted_arr) -! do k=1,grid%nVertLevels+1 -! target_z = grid % zgrid % array(k,iCell) -! fg % gfs_p % array(k,iCell) = exp(vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1)) +! do k=1,nVertLevels+1 +! target_z = zgrid(k,iCell) +! gfs_p(k,iCell) = exp(vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1)) ! end do end do - do iEdge=1,grid%nEdges + do iEdge=1,nEdges ! U sorted_arr(:,:) = -999.0 do k=1,nfglevels_actual - sorted_arr(1,k) = 0.5 * (fg % z % array(k,cellsOnEdge(1,iEdge)) + fg % z % array(k,cellsOnEdge(2,iEdge))) + sorted_arr(1,k) = 0.5 * (z_fg(k,cellsOnEdge(1,iEdge)) + z_fg(k,cellsOnEdge(2,iEdge))) !NOSFC if (vert_level(k) == 200100.0) sorted_arr(1,k) = 0.5 * (fg % soilz % array(cellsOnEdge(1,iEdge)) + fg % soilz % array(cellsOnEdge(2,iEdge))) if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 - sorted_arr(2,k) = fg % u % array(k,iEdge) + sorted_arr(2,k) = u_fg(k,iEdge) end do call mpas_quicksort(nfglevels_actual, sorted_arr) - do k=1,grid%nVertLevels - target_z = 0.25 * (grid % zgrid % array(k,cellsOnEdge(1,iEdge)) + grid % zgrid % array(k+1,cellsOnEdge(1,iEdge)) + grid % zgrid % array(k,cellsOnEdge(2,iEdge)) + grid % zgrid % array(k+1,cellsOnEdge(2,iEdge))) -! state % u % array(k,iEdge) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=0) - state % u % array(k,iEdge) = vertical_interp(target_z, nfglevels_actual-1, & - sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) + do k=1,nVertLevels + target_z = 0.25 * (zgrid(k,cellsOnEdge(1,iEdge)) + zgrid(k+1,cellsOnEdge(1,iEdge)) + zgrid(k,cellsOnEdge(2,iEdge)) + zgrid(k+1,cellsOnEdge(2,iEdge))) +! u(k,iEdge) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=0) + u(k,iEdge) = vertical_interp(target_z, nfglevels_actual-1, sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) end do end do @@ -3570,14 +4093,14 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! ! Reconstruct zonal and meridional winds for diagnostic puposes: ! - call mpas_rbf_interp_initialize(grid) - call mpas_init_reconstruct(grid) - call mpas_reconstruct(grid, state % u % array, & - diag % uReconstructX % array, & - diag % uReconstructY % array, & - diag % uReconstructZ % array, & - diag % uReconstructZonal % array, & - diag % uReconstructMeridional % array & + call mpas_rbf_interp_initialize(mesh) + call mpas_init_reconstruct(mesh) + call mpas_reconstruct(mesh, u, & + uReconstructX, & + uReconstructY, & + uReconstructZ, & + uReconstructZonal, & + uReconstructMeridional & ) @@ -3587,21 +4110,21 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) do sfc_k=1,nfglevels_actual if (vert_level(sfc_k) == 200100.) exit end do - do iCell=1,grid%nCells + do iCell=1,nCells ! We need to extrapolate sorted_arr(:,:) = -999.0 do k=1,nfglevels_actual - sorted_arr(1,k) = fg % z % array(k,iCell) + sorted_arr(1,k) = z_fg(k,iCell) if (vert_level(k) == 200100.0) then !NOSFC sorted_arr(1,k) = fg % soilz % array(iCell) sorted_arr(1,k) = 99999.0 end if - sorted_arr(2,k) = log(fg % p % array(k,iCell)) + sorted_arr(2,k) = log(p_fg(k,iCell)) end do call mpas_quicksort(nfglevels_actual, sorted_arr) - target_z = grid % zgrid % array(1,iCell) - fg % psfc % array(iCell) = exp(vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1)) + target_z = zgrid(1,iCell) + psfc(iCell) = exp(vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=1)) end do @@ -3613,24 +4136,25 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! Diagnose fields needed in initial conditions file (u, w, rho, theta, scalars) ! NB: At this point, "rho_zz" is simple dry density, and "theta_m" is regular potential temperature ! - do iCell=1,grid%nCells - do k=1,grid%nVertLevels + do iCell=1,nCells + do k=1,nVertLevels ! QV - es = 6.112 * exp((17.27*(state % theta_m % array(k,iCell) - 273.16))/(state % theta_m % array(k,iCell) - 35.86)) - rs = 0.622 * es * 100. / (diag % pressure % array(k,iCell) - es * 100.) - scalars(state % index_qv,k,iCell) = 0.01 * rs * scalars(state % index_qv,k,iCell) + es = 6.112 * exp((17.27*(t(k,iCell) - 273.16))/(t(k,iCell) - 35.86)) + es = min(es,0.99*0.01*pressure(k,iCell)) ! WCS 20141003, from LF; temporary fix + rs = 0.622 * es * 100. / (pressure(k,iCell) - es * 100.) + scalars(index_qv,k,iCell) = 0.01 * rs * scalars(index_qv,k,iCell) ! PI - p(k,iCell) = (diag % pressure % array(k,iCell) / p0) ** (rgas / cp) + p(k,iCell) = (pressure(k,iCell) / p0) ** (rgas / cp) ! THETA - can compute this using PI instead ! t(k,iCell) = t(k,iCell) / p(k,iCell) - t(k,iCell) = t(k,iCell) * (p0 / diag % pressure % array(k,iCell)) ** (rgas / cp) + t(k,iCell) = t(k,iCell) * (p0 / pressure(k,iCell)) ** (rgas / cp) ! RHO_ZZ - rho_zz(k,iCell) = diag % pressure % array(k,iCell) / rgas / (p(k,iCell) * t(k,iCell)) - rho_zz(k,iCell) = rho_zz(k,iCell) / (1.0 + scalars(state % index_qv,k,iCell)) + rho_zz(k,iCell) = pressure(k,iCell) / rgas / (p(k,iCell) * t(k,iCell)) + rho_zz(k,iCell) = rho_zz(k,iCell) / (1.0 + scalars(index_qv,k,iCell)) end do end do @@ -3638,18 +4162,17 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! ! Calculation of the initial precipitable water: ! - do iCell = 1,grid%nCells - diag_physics%precipw%array(iCell) = 0.0 - do k = 1,grid%nVertLevels - diag_physics%precipw%array(iCell) = diag_physics%precipw%array(iCell) & - + rho_zz(k,iCell)*scalars(state%index_qv,k,iCell)*(zgrid(k+1,iCell)-zgrid(k,iCell)) - enddo - enddo + do iCell = 1,nCells + precipw(iCell) = 0.0 + do k = 1,nVertLevels + precipw(iCell) = precipw(iCell) + rho_zz(k,iCell)*scalars(index_qv,k,iCell)*(zgrid(k+1,iCell)-zgrid(k,iCell)) + end do + end do ! ! Reference state based on a dry isothermal atmosphere ! - do iCell=1,grid % nCells + do iCell=1,nCells do k=1,nz1 ztemp = 0.5*(zgrid(k+1,iCell)+zgrid(k,iCell)) ppb(k,iCell) = p0*exp(-gravity*ztemp/(rgas*t0b)) ! pressure_base @@ -3664,28 +4187,28 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) end do end do - do iCell=1,grid%nCells - do k=1,grid%nVertLevels + do iCell=1,nCells + do k=1,nVertLevels ! WCS 20130821 - couple with vertical metric rb(k,iCell) = rb(k,iCell) / zz(k,iCell) rho_zz(k,iCell) = rho_zz(k,iCell) / zz(k,iCell) - pp(k,iCell) = diag % pressure % array(k,iCell) - ppb(k,iCell) + pp(k,iCell) = pressure(k,iCell) - ppb(k,iCell) rr(k,iCell) = rho_zz(k,iCell) - rb(k,iCell) end do end do - do iCell=1,grid%nCells + do iCell=1,nCells k = 1 ! WCS 20130821 - couple with vertical metric, note: rr is coupled here - rho_zz(k,iCell) = ((diag % pressure % array(k,iCell) / p0)**(cv / cp)) * (p0 / rgas) & - / (t(k,iCell)*(1.0 + 1.61*scalars(state % index_qv,k,iCell))) / zz(k,iCell) + rho_zz(k,iCell) = ((pressure(k,iCell) / p0)**(cv / cp)) * (p0 / rgas) & + / (t(k,iCell)*(1.0 + 1.61*scalars(index_qv,k,iCell))) / zz(k,iCell) rr(k,iCell) = rho_zz(k,iCell) - rb(k,iCell) - do k=2,grid % nVertLevels + do k=2,nVertLevels it = 0 p_check = 2.0 * 0.0001 do while ( (it < 30) .and. (p_check > 0.0001) ) @@ -3693,13 +4216,13 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) p_check = pp(k,iCell) ! WCS 20130821 - MPAS hydrostatic relation pp(k,iCell) = pp(k-1,iCell) - (fzm(k)*rr(k,iCell) + fzp(k)*rr(k-1,iCell))*gravity*dzu(k) & - - (fzm(k)*rho_zz(k,iCell)*scalars(state % index_qv,k,iCell) & - + fzp(k)*rho_zz(k-1,iCell)*scalars(state % index_qv,k-1,iCell))*gravity*dzu(k) - diag % pressure % array(k,iCell) = pp(k,iCell) + ppb(k,iCell) - p(k,iCell) = (diag % pressure % array(k,iCell) / p0) ** (rgas / cp) + - (fzm(k)*rho_zz(k,iCell)*scalars(index_qv,k,iCell) & + + fzp(k)*rho_zz(k-1,iCell)*scalars(index_qv,k-1,iCell))*gravity*dzu(k) + pressure(k,iCell) = pp(k,iCell) + ppb(k,iCell) + p(k,iCell) = (pressure(k,iCell) / p0) ** (rgas / cp) ! WCS 20130821 - couple with vertical metric - rho_zz(k,iCell) = diag % pressure % array(k,iCell) / rgas & - / (p(k,iCell)*t(k,iCell)*(1.0 + 1.61*scalars(state % index_qv,k,iCell)))/zz(k,iCell) + rho_zz(k,iCell) = pressure(k,iCell) / rgas & + / (p(k,iCell)*t(k,iCell)*(1.0 + 1.61*scalars(index_qv,k,iCell)))/zz(k,iCell) rr(k,iCell) = rho_zz(k,iCell) - rb(k,iCell) p_check = abs(p_check - pp(k,iCell)) @@ -3710,9 +4233,9 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) end do ! Compute theta_m and rho-tilde - do iCell=1,grid%nCells - do k=1,grid%nVertLevels - t(k,iCell) = t(k,iCell) * (1.0 + 1.61*scalars(state % index_qv,k,iCell)) + do iCell=1,nCells + do k=1,nVertLevels + t(k,iCell) = t(k,iCell) * (1.0 + 1.61*scalars(index_qv,k,iCell)) !! WCS 20130821 - coupling with vertical metric already accomplished... !! rho_zz(k,iCell) = rho_zz(k,iCell) / zz(k,iCell) !! rb(k,iCell) = rb(k,iCell) / zz(k,iCell) @@ -3721,33 +4244,33 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) end do end do - do iEdge=1,grid%nEdges - do k=1,grid%nVertLevels - diag % ru % array(k,iEdge) = state % u % array(k,iEdge) * 0.5*(state % rho_zz % array(k,cellsOnEdge(1,iEdge)) + state % rho_zz % array(k,cellsOnEdge(2,iEdge))) + do iEdge=1,nEdges + do k=1,nVertLevels + ru(k,iEdge) = u(k,iEdge) * 0.5*(rho_zz(k,cellsOnEdge(1,iEdge)) + rho_zz(k,cellsOnEdge(2,iEdge))) end do end do - diag % rw % array = 0. - state % w % array = 0. - do iEdge = 1,grid % nEdges + rw= 0.0 + w = 0.0 + do iEdge = 1,nEdges - cell1 = CellsOnEdge(1,iEdge) - cell2 = CellsOnEdge(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - 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 + do k = 2, nVertLevels + flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge)) + rw(k,cell2) = rw(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux + rw(k,cell1) = rw(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 + rw(k,cell2) = rw(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 + rw(k,cell1) = rw(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 @@ -3756,10 +4279,9 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) 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)) + do iCell=1,nCells + do k=2,nVertLevels + w(k,iCell) = rw(k,iCell) / (fzp(k) * rho_zz(k-1,iCell) + fzm(k) * rho_zz(k,iCell)) end do end do @@ -3768,18 +4290,18 @@ subroutine init_atm_case_gfs(grid, fg, state, diag, diag_physics, init_case) ! Calculate surface pressure (This is an ad-hoc calculation. The actual surface pressure is actually re-calculated at !the top of the subroutine MPAS_to_physics in ../core_atmos_physics/mpas_atmphys_interface_nhyd.F - do iCell=1,grid%nCells - diag % surface_pressure % array(iCell) = 0.5*gravity/rdzw(1) & - * (1.25* rho_zz(1,iCell) * (1. + scalars(state % index_qv, 1, iCell)) & - - 0.25* rho_zz(2,iCell) * (1. + scalars(state % index_qv, 2, iCell))) - diag % surface_pressure % array(iCell) = diag % surface_pressure % array(iCell) + pp(1,iCell) + ppb(1,iCell) + do iCell=1,nCells + surface_pressure(iCell) = 0.5*gravity/rdzw(1) & + * (1.25* rho_zz(1,iCell) * (1. + scalars(index_qv, 1, iCell)) & + - 0.25* rho_zz(2,iCell) * (1. + scalars(index_qv, 2, iCell))) + surface_pressure(iCell) = surface_pressure(iCell) + pp(1,iCell) + ppb(1,iCell) 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(state % index_qv,k,iCell)) + do iCell=1,nCells + do k=1,nVertLevels + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + theta(k,iCell) = t(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell)) end do end do @@ -3978,106 +4500,148 @@ subroutine physics_idealized_init(mesh, fg) implicit none - !input and output arguments: - type(mesh_type),intent(inout):: mesh - type (fg_type), intent(inout) :: fg + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: fg !local variables: - integer:: iCell,iMonth,iSoil + integer :: iCell, iMonth, iSoil + integer, pointer :: nCells, nSoilLevels, nMonths + integer, dimension(:), pointer :: landmask, lu_index, soilcat_top + real (kind=RKIND), dimension(:), pointer :: ter, xice, shdmin, shdmax, vegfra, sfc_albbck, xland, seaice + real (kind=RKIND), dimension(:), pointer :: snow, snowc, snoalb, snowh, skintemp, sst, tmn + real (kind=RKIND), dimension(:,:), pointer :: tslb, smcrel, sh2o, smois, dzs, albedo12m, greenfrac !--------------------------------------------------------------------------------------------- + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nSoilLevels', nSoilLevels) + call mpas_pool_get_dimension(mesh, 'nMonths', nMonths) + + call mpas_pool_get_array(mesh, 'ter', ter) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) + call mpas_pool_get_array(mesh, 'shdmin', shdmin) + call mpas_pool_get_array(mesh, 'shdmax', shdmax) + call mpas_pool_get_array(mesh, 'snoalb', snoalb) + call mpas_pool_get_array(mesh, 'albedo12m', albedo12m) + call mpas_pool_get_array(mesh, 'greenfrac', greenfrac) + + call mpas_pool_get_array(fg, 'xice', xice) + call mpas_pool_get_array(fg, 'vegfra', vegfra) + call mpas_pool_get_array(fg, 'sfc_albbck', sfc_albbck) + call mpas_pool_get_array(fg, 'xland', xland) + call mpas_pool_get_array(fg, 'seaice', seaice) + call mpas_pool_get_array(fg, 'snow', snow) + call mpas_pool_get_array(fg, 'snowc', snowc) + call mpas_pool_get_array(fg, 'snowh', snowh) + call mpas_pool_get_array(fg, 'skintemp', skintemp) + call mpas_pool_get_array(fg, 'sst', sst) + call mpas_pool_get_array(fg, 'tmn', tmn) + call mpas_pool_get_array(fg, 'tslb', tslb) + call mpas_pool_get_array(fg, 'smcrel', smcrel) + call mpas_pool_get_array(fg, 'sh2o', sh2o) + call mpas_pool_get_array(fg, 'smois', smois) + call mpas_pool_get_array(fg, 'dzs', dzs) !initialization of surface input variables that are not needed if we run the current set of !idealized test cases: - do iCell = 1, mesh % nCells + do iCell = 1, nCells !terrain,soil type, and vegetation: - mesh % ter % array(iCell) = 0. - fg % xice % array(iCell) = 0. - mesh % landmask % array(iCell) = 0 - mesh % lu_index % array(iCell) = 0 - mesh % soilcat_top % array(iCell) = 0 - mesh % shdmin % array(iCell) = 0. - mesh % shdmax % array(iCell) = 0. - fg % vegfra % array(iCell) = 0. - fg % sfc_albbck % array(iCell) = 0. - fg % xland % array(iCell) = 0. - fg % seaice % array(iCell) = 0. + ter(iCell) = 0.0 + xice(iCell) = 0.0 + landmask(iCell) = 0 + lu_index(iCell) = 0 + soilcat_top(iCell) = 0 + shdmin(iCell) = 0.0 + shdmax(iCell) = 0.0 + vegfra(iCell) = 0.0 + sfc_albbck(iCell) = 0.0 + xland(iCell) = 0.0 + seaice(iCell) = 0.0 !snow coverage: - fg % snow % array(iCell) = 0. - fg % snowc % array(iCell) = 0. - mesh % snoalb % array(iCell) = 0.08 - fg % snowh % array(iCell) = 0. + snow(iCell) = 0.0 + snowc(iCell) = 0.0 + snoalb(iCell) = 0.08 + snowh(iCell) = 0.0 !surface and sea-surface temperatures: - fg % skintemp % array(iCell) = 288.0 - fg % sst % array(iCell) = 288.0 + skintemp(iCell) = 288.0 + sst(iCell) = 288.0 !soil layers: - fg % tmn % array(iCell) = 288.0 - do iSoil = 1, mesh % nSoilLevels - fg % tslb % array(iSoil,iCell) = 288.0 - fg % smcrel % array(iSoil,iCell) = 0.0 - fg % sh2o % array(iSoil,iCell) = 0.0 - fg % smois % array(iSoil,iCell) = 0.0 - fg % dzs % array(iSoil,iCell) = 0.0 - enddo + tmn(iCell) = 288.0 + do iSoil = 1, nSoilLevels + tslb(iSoil,iCell) = 288.0 + smcrel(iSoil,iCell) = 0.0 + sh2o(iSoil,iCell) = 0.0 + smois(iSoil,iCell) = 0.0 + dzs(iSoil,iCell) = 0.0 + end do !monthly climatological surface albedo and greeness fraction: - do iMonth = 1, mesh % nMonths - mesh % albedo12m % array(iMonth,iCell) = 0.08 - mesh % greenfrac % array(iMonth,iCell) = 0. - enddo + do iMonth = 1, nMonths + albedo12m(iMonth,iCell) = 0.08 + greenfrac(iMonth,iCell) = 0.0 + end do - enddo + end do end subroutine physics_idealized_init - subroutine decouple_variables(grid, state, diag) + subroutine decouple_variables(mesh, nCells, nVertLevels, state, diag) implicit none - type (mesh_type), intent(in) :: grid - type (state_type), intent(inout) :: state - type (diag_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag integer :: iCell, iEdge, k integer, dimension(:,:), pointer :: cellsOnEdge - real (kind=RKIND), dimension(:), pointer :: fzm, fzp, rdzw - real (kind=RKIND), dimension(:,:), pointer :: zz, pp, ppb + real (kind=RKIND), dimension(:), pointer :: rdzw + real (kind=RKIND), dimension(:,:), pointer :: zz, pp, ppb, rho, rho_zz, theta, theta_m + real (kind=RKIND), dimension(:), pointer :: surface_pressure real (kind=RKIND), dimension(:,:,:), pointer :: scalars - cellsOnEdge => grid % CellsOnEdge % array - fzp => grid % fzm % array - fzp => grid % fzp % array - rdzw => grid % rdzw % array - zz => grid % zz % array - - pp => diag % pressure_p % array - ppb => diag % pressure_base % array - - scalars => state % scalars % array - + integer, pointer :: index_qv + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'surface_pressure', surface_pressure) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(state, 'theta_m', theta_m) + call mpas_pool_get_array(state, 'scalars', scalars) + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) ! Compute surface pressure - do iCell=1,grid%nCells - diag % surface_pressure % array(iCell) = 0.5*gravity/rdzw(1) & - * (1.25* state % rho_zz % array(1,iCell) * (1. + scalars(state % index_qv, 1, iCell)) & - - 0.25* state % rho_zz % array(2,iCell) * (1. + scalars(state % index_qv, 2, iCell))) - diag % surface_pressure % array(iCell) = diag % surface_pressure % array(iCell) + pp(1,iCell) + ppb(1,iCell) + do iCell=1,nCells + surface_pressure(iCell) = 0.5*gravity/rdzw(1) & + * (1.25* rho_zz(1,iCell) * (1. + scalars(index_qv, 1, iCell)) & + - 0.25* rho_zz(2,iCell) * (1. + scalars(index_qv, 2, iCell))) + surface_pressure(iCell) = surface_pressure(iCell) + pp(1,iCell) + ppb(1,iCell) 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(state % index_qv,k,iCell)) + do iCell=1,nCells + do k=1,nVertLevels + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + theta(k,iCell) = theta_m(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell)) end do end do diff --git a/src/core_init_atmosphere/mpas_init_atm_llxy.F b/src/core_init_atmosphere/mpas_init_atm_llxy.F index ea76ef4730..939b588acc 100644 --- a/src/core_init_atmosphere/mpas_init_atm_llxy.F +++ b/src/core_init_atmosphere/mpas_init_atm_llxy.F @@ -2227,8 +2227,7 @@ SUBROUTINE llxy_error_fatal(mesg) CHARACTER (LEN=*), INTENT(IN) :: mesg - WRITE(0,*) trim(mesg) - STOP + CALL mpas_dmpar_global_abort(trim(mesg)) END SUBROUTINE llxy_error_fatal diff --git a/src/core_init_atmosphere/mpas_init_atm_mpas_core.F b/src/core_init_atmosphere/mpas_init_atm_mpas_core.F index 47a7c194b5..4938528242 100644 --- a/src/core_init_atmosphere/mpas_init_atm_mpas_core.F +++ b/src/core_init_atmosphere/mpas_init_atm_mpas_core.F @@ -11,46 +11,73 @@ module mpas_core contains - subroutine mpas_core_init(domain, startTimeStamp) + subroutine mpas_core_init(domain, stream_manager, startTimeStamp) use mpas_grid_types + use mpas_stream_manager + use mpas_io_streams, only : MPAS_STREAM_NEAREST use mpas_configure use init_atm_cases implicit none type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager character(len=*), intent(out) :: startTimeStamp type (block_type), pointer :: block + type (mpas_pool_type), pointer :: state, mesh + character (len=StrKIND), pointer :: xtime + character (len=StrKIND), pointer :: config_start_time + real (kind=RKIND), pointer :: sphere_radius + integer :: ierr - startTimeStamp = config_start_time block => domain % blocklist do while (associated(block)) - block % state % time_levs(1) % state % xtime % scalar = startTimeStamp - block % mesh % sphere_radius = a + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_array(state, 'xtime', xtime) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + call mpas_pool_get_config(block % configs, 'config_start_time', config_start_time) + + startTimeStamp = config_start_time + xtime = config_start_time + domain % sphere_radius = a ! Appears in output files + sphere_radius = a ! Used in setting up test cases + block => block % next end do + call MPAS_stream_mgr_add_att(stream_manager, 'sphere_radius', domain % sphere_radius, streamID='output', ierr=ierr) + call MPAS_stream_mgr_add_att(stream_manager, 'sphere_radius', domain % sphere_radius, streamID='surface', ierr=ierr) + + ! + ! We don't actually expect the time in the (most likely 'static') file to + ! match the time in the namelist, so just read whatever time we find in + ! the input file. + ! + call MPAS_stream_mgr_read(stream_manager, whence=MPAS_STREAM_NEAREST, ierr=ierr) + call MPAS_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_INPUT, ierr=ierr) + end subroutine mpas_core_init - subroutine mpas_core_run(domain, output_obj, output_frame) + subroutine mpas_core_run(domain, stream_manager) use mpas_grid_types - use mpas_io_output + use mpas_stream_manager use mpas_timer use init_atm_cases implicit none type (domain_type), intent(inout) :: domain - type (io_output_object), intent(inout) :: output_obj - integer, intent(inout) :: output_frame + type (MPAS_streamManager_type), intent(inout) :: stream_manager + integer :: ierr - call init_atm_setup_case(domain) + call init_atm_setup_case(domain, stream_manager) ! ! Note: The following initialization calls have been moved to the mpas_init_atm_case_*() subroutines, @@ -59,45 +86,152 @@ subroutine mpas_core_run(domain, output_obj, output_frame) ! call atm_initialize_advection_rk(mesh) ! call atm_initialize_deformation_weights(mesh) - call mpas_output_state_for_domain(output_obj, domain, output_frame) + call mpas_stream_mgr_write(stream_manager, streamID='output', ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) end subroutine mpas_core_run - subroutine mpas_core_finalize(domain) + subroutine mpas_core_finalize(domain, stream_manager) use mpas_grid_types + use mpas_stream_manager implicit none type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager end subroutine mpas_core_finalize -!*********************************************************************** -! -! routine mpas_core_setup_packages -! -!> \brief Pacakge setup routine -!> \author Doug Jacobsen -!> \date September 2011 -!> \details -!> This routine is intended to correctly configure the packages for this MPAS -!> core. It can use any Fortran logic to properly configure packages, and it -!> can also make use of any namelist options. All variables in the model are -!> *not* allocated until after this routine is called. -! -!----------------------------------------------------------------------- - subroutine mpas_core_setup_packages(ierr)!{{{ + + subroutine mpas_core_setup_packages(configs, packages, ierr) use mpas_packages + use mpas_grid_types implicit none + type (mpas_pool_type), intent(inout) :: configs + type (mpas_pool_type), intent(inout) :: packages integer, intent(out) :: ierr + logical, pointer :: initial_conds, sfc_update + integer, pointer :: config_init_case + ierr = 0 - end subroutine mpas_core_setup_packages!}}} + nullify(config_init_case) + call mpas_pool_get_config(configs, 'config_init_case', config_init_case) + + nullify(initial_conds) + call mpas_pool_get_package(packages, 'initial_condsActive', initial_conds) + + nullify(sfc_update) + call mpas_pool_get_package(packages, 'sfc_updateActive', sfc_update) + + if (.not. associated(config_init_case) .or. & + .not. associated(initial_conds) .or. & + .not. associated(sfc_update)) then + write(stderrUnit,*) '********************************************************************************' + write(stderrUnit,*) '* Error while setting up packages for init_atmosphere core.' + write(stderrUnit,*) '********************************************************************************' + ierr = 1 + return + end if + + if (config_init_case == 8) then + initial_conds = .false. + sfc_update = .true. + else + initial_conds = .true. + sfc_update = .false. + end if + + end subroutine mpas_core_setup_packages + + + + !*********************************************************************** + ! + ! routine mpas_core_setup_clock + ! + !> \brief Pacakge setup routine + !> \author Michael Duda + !> \date 6 August 2014 + !> \details + !> The purpose of this routine is to allow the core to set up a simulation + !> clock that will be used by the I/O subsystem for timing reads and writes + !> of I/O streams. + !> This routine is called from the superstructure after the framework + !> has been initialized but before any fields have been allocated and + !> initial fields have been read from input files. However, all namelist + !> options are available. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_setup_clock(core_clock, configs, ierr) + + use mpas_timekeeping, only : MPAS_Clock_type, MPAS_Time_type, MPAS_Timeinterval_type, & + mpas_set_time, mpas_set_timeInterval, mpas_create_clock + use mpas_grid_types, only : mpas_pool_type, mpas_pool_get_config + use mpas_kind_types, only : StrKIND + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + character(len=StrKIND), pointer :: config_start_time, config_stop_time + integer, pointer :: config_fg_interval + + type (MPAS_Time_type) :: start_time, stop_time + type (MPAS_TimeInterval_type) :: dt + + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) + call mpas_pool_get_config(configs, 'config_fg_interval', config_fg_interval) + + call mpas_set_time(start_time, dateTimeString=trim(config_start_time)) + call mpas_set_time(stop_time, dateTimeString=trim(config_stop_time)) + call mpas_set_timeInterval(dt, S=config_fg_interval) + call mpas_create_clock(core_clock, start_time, dt, stopTime=stop_time) + + end subroutine mpas_core_setup_clock + + + !*********************************************************************** + ! + ! routine mpas_core_get_mesh_stream + ! + !> \brief Returns the name of the stream containing mesh information + !> \author Michael Duda + !> \date 8 August 2014 + !> \details + !> This routine returns the name of the I/O stream containing dimensions, + !> attributes, and mesh fields needed by the framework bootstrapping + !> routine. At the time this routine is called, only namelist options + !> are available. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_get_mesh_stream(configs, stream, ierr) + + use mpas_grid_types, only : mpas_pool_type, mpas_pool_get_config + + implicit none + + type (mpas_pool_type), intent(in) :: configs + character(len=*), intent(out) :: stream + integer, intent(out) :: ierr + + + ierr = 0 + + write(stream,'(a)') 'input' + + end subroutine mpas_core_get_mesh_stream end module mpas_core diff --git a/src/core_init_atmosphere/mpas_init_atm_read_met.F b/src/core_init_atmosphere/mpas_init_atm_read_met.F index 46e7442c3d..435503a732 100644 --- a/src/core_init_atmosphere/mpas_init_atm_read_met.F +++ b/src/core_init_atmosphere/mpas_init_atm_read_met.F @@ -310,6 +310,8 @@ subroutine read_next_met_field(fg_data, istatus) fg_data % deltalat, & fg_data % deltalon, & fg_data % earth_radius + fg_data % dx = 0.0 + fg_data % dy = 0.0 ! Mercator else if (fg_data % iproj == 1) then @@ -344,6 +346,8 @@ subroutine read_next_met_field(fg_data, istatus) fg_data % deltalat, & fg_data % deltalon, & fg_data % earth_radius + fg_data % dx = 0.0 + fg_data % dy = 0.0 ! Polar stereographic else if (fg_data % iproj == 5) then diff --git a/src/core_init_atmosphere/mpas_init_atm_static.F b/src/core_init_atmosphere/mpas_init_atm_static.F index 2e11362b05..be6e1c0905 100644 --- a/src/core_init_atmosphere/mpas_init_atm_static.F +++ b/src/core_init_atmosphere/mpas_init_atm_static.F @@ -9,7 +9,7 @@ module mpas_init_atm_static !================================================================================================== use atm_advection - use mpas_configure +! use mpas_configure use mpas_dmpar use init_atm_hinterp use init_atm_llxy @@ -27,18 +27,24 @@ module mpas_init_atm_static contains !================================================================================================== - subroutine init_atm_static(mesh) + subroutine init_atm_static(mesh, dims, configs) !================================================================================================== !inout arguments: - type(mesh_type),intent(inout):: mesh + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs !local variables: type(proj_info):: proj - type(dm_info),pointer :: dminfo - character(len=StrKIND):: fname - character(len=StrKIND+1):: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash + character(len=StrKIND) :: fname + character(len=StrKIND), pointer :: config_geog_data_path + character(len=StrKIND), pointer :: config_landuse_data + character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash + character(len=StrKIND+1) :: geog_sub_path ! subdirectory names in config_geog_data_path, with trailing slash + + integer:: isice_lu,iswater_lu,ismax_lu integer:: nx,ny,nz integer:: endian,isigned,istatus,wordsize @@ -51,21 +57,50 @@ subroutine init_atm_static(mesh) real(kind=4):: scalefactor real(kind=4),dimension(:,:,:),allocatable:: rarray - real(kind=RKIND):: r_earth real(kind=RKIND):: lat,lon,x,y real(kind=RKIND):: lat_pt,lon_pt real(kind=RKIND),dimension(:,:),allocatable :: soiltemp_1deg real(kind=RKIND),dimension(:,:),allocatable :: maxsnowalb real(kind=RKIND),dimension(:,:,:),allocatable:: vegfra + integer, pointer :: nCells, nEdges, nVertices, maxEdges + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge + real (kind=RKIND), dimension(:), pointer :: areaCell, areaTriangle + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latVertex, lonVertex + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: fEdge, fVertex + + real (kind=RKIND), dimension(:), pointer :: ter + real (kind=RKIND), dimension(:), pointer :: soiltemp + real (kind=RKIND), dimension(:), pointer :: snoalb + real (kind=RKIND), dimension(:), pointer :: shdmin, shdmax + real (kind=RKIND), dimension(:,:), pointer :: greenfrac + real (kind=RKIND), dimension(:,:), pointer :: albedo12m + integer, dimension(:), pointer :: lu_index + integer, dimension(:), pointer :: soilcat_top + integer, dimension(:), pointer :: soilcat_bot + integer, dimension(:), pointer :: landmask + character(len=StrKIND), pointer :: mminlu !-------------------------------------------------------------------------------------------------- - dminfo => mesh % block % domain % dminfo write(0,*) write(0,*) '--- enter subroutine init_atm_static:' + call mpas_pool_get_config(configs, 'config_geog_data_path', config_geog_data_path) + call mpas_pool_get_config(configs, 'config_landuse_data', config_landuse_data) + write(geog_data_path, '(a)') config_geog_data_path i = len_trim(geog_data_path) if (geog_data_path(i:i) /= '/') then @@ -76,40 +111,109 @@ subroutine init_atm_static(mesh) ! Scale all distances and areas from a unit sphere to one with radius sphere_radius ! - r_earth = mesh % sphere_radius - - mesh % xCell % array = mesh % xCell % array * r_earth - mesh % yCell % array = mesh % yCell % array * r_earth - mesh % zCell % array = mesh % zCell % array * r_earth - mesh % xVertex % array = mesh % xVertex % array * r_earth - mesh % yVertex % array = mesh % yVertex % array * r_earth - mesh % zVertex % array = mesh % zVertex % array * r_earth - mesh % xEdge % array = mesh % xEdge % array * r_earth - mesh % yEdge % array = mesh % yEdge % array * r_earth - mesh % zEdge % array = mesh % zEdge % array * r_earth - mesh % dvEdge % array = mesh % dvEdge % array * r_earth - mesh % dcEdge % array = mesh % dcEdge % array * r_earth - mesh % areaCell % array = mesh % areaCell % array * r_earth**2.0 - mesh % areaTriangle % array = mesh % areaTriangle % array * r_earth**2.0 - mesh % kiteAreasOnVertex % array = mesh % kiteAreasOnVertex % array * r_earth**2.0 - - - ! - ! Initialize Coriolis parameter field on edges and vertices - ! - do iEdge=1,mesh % nEdges - mesh % fEdge % array(iEdge) = 2.0 * omega * sin(mesh % latEdge % array(iEdge)) + + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + call mpas_pool_get_array(mesh, 'latVertex', latVertex) + call mpas_pool_get_array(mesh, 'lonVertex', lonVertex) + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + + call mpas_pool_get_array(mesh, 'ter', ter) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + call mpas_pool_get_array(mesh, 'mminlu', mminlu) + call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) + call mpas_pool_get_array(mesh, 'soilcat_bot', soilcat_bot) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'soiltemp', soiltemp) + call mpas_pool_get_array(mesh, 'snoalb', snoalb) + call mpas_pool_get_array(mesh, 'greenfrac', greenfrac) + call mpas_pool_get_array(mesh, 'albedo12m', albedo12m) + call mpas_pool_get_array(mesh, 'shdmin', shdmin) + call mpas_pool_get_array(mesh, 'shdmax', shdmax) + + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_dimension(dims, 'nEdges', nEdges) + call mpas_pool_get_dimension(dims, 'nVertices', nVertices) + call mpas_pool_get_dimension(dims, 'maxEdges', maxEdges) + + xCell = xCell * sphere_radius + yCell = yCell * sphere_radius + zCell = zCell * sphere_radius + xVertex = xVertex * sphere_radius + yVertex = yVertex * sphere_radius + zVertex = zVertex * sphere_radius + xEdge = xEdge * sphere_radius + yEdge = yEdge * sphere_radius + zEdge = zEdge * sphere_radius + dvEdge = dvEdge * sphere_radius + dcEdge = dcEdge * sphere_radius + areaCell = areaCell * sphere_radius**2.0 + areaTriangle = areaTriangle * sphere_radius**2.0 + kiteAreasOnVertex = kiteAreasOnVertex * sphere_radius**2.0 + + +! +! Initialize Coriolis parameter field on edges and vertices +! + do iEdge=1,nEdges + fEdge(iEdge) = 2.0 * omega * sin(latEdge(iEdge)) end do - do iVtx=1,mesh % nVertices - mesh % fVertex % array(iVtx) = 2.0 * omega * sin(mesh % latVertex % array(iVtx)) + do iVtx=1,nVertices + fVertex(iVtx) = 2.0 * omega * sin(latVertex(iVtx)) end do - ! - ! Compute weights used in advection and deformation calculation - ! - call atm_initialize_advection_rk(mesh) - call atm_initialize_deformation_weights(mesh) +! +! Compute weights used in advection and deformation calculation +! + call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + + +! +! Set land use and soil category parameters for water and ice +! + surface_input_select0: select case(trim(config_landuse_data)) + case('USGS') + isice_lu = 24 + iswater_lu = 16 + ismax_lu = 24 + write(mminlu,'(a)') 'USGS' + case('MODIFIED_IGBP_MODIS_NOAH') + isice_lu = 15 + iswater_lu = 17 + ismax_lu = 20 + write(mminlu,'(a)') 'MODIFIED_IGBP_MODIS_NOAH' + case default + write(0,*) '*****************************************************************' + write(0,*) 'Invalid land use dataset '''//trim(config_landuse_data)//''' selected for config_landuse_data' + write(0,*) ' Possible options are: ''USGS'', ''MODIFIED_IGBP_MODIS_NOAH''' + write(0,*) '*****************************************************************' + call mpas_dmpar_global_abort('Please correct the namelist.') + end select surface_input_select0 ! @@ -125,9 +229,9 @@ subroutine init_atm_static(mesh) wordsize = 2 scalefactor = 1.0 allocate(rarray(nx,ny,nz)) - allocate(nhs(mesh%nCells)) + allocate(nhs(nCells)) nhs(:) = 0 - mesh%ter%array(:) = 0.0 + ter(:) = 0.0 do jTileStart = 1,20401,ny-6 jTileEnd = jTileStart + ny - 1 - 6 @@ -140,7 +244,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname, dminfo) + call init_atm_check_read_error(istatus, fname) iPoint = 1 do j=4,ny-3 @@ -150,10 +254,10 @@ subroutine init_atm_static(mesh) lat_pt = lat_pt * PI / 180.0 lon_pt = lon_pt * PI / 180.0 - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, & - mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, & - mesh%latCell%array,mesh%lonCell%array) - mesh%ter%array(iPoint) = mesh%ter%array(iPoint) + rarray(i,j,1) + iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & + nEdgesOnCell,cellsOnCell, & + latCell,lonCell) + ter(iPoint) = ter(iPoint) + rarray(i,j,1) nhs(iPoint) = nhs(iPoint) + 1 end do end do @@ -161,8 +265,8 @@ subroutine init_atm_static(mesh) end do end do - do iCell = 1,mesh%nCells - mesh%ter%array(iCell) = mesh%ter%array(iCell) / real(nhs(iCell)) + do iCell = 1,nCells + ter(iCell) = ter(iCell) / real(nhs(iCell)) end do deallocate(rarray) deallocate(nhs) @@ -172,6 +276,18 @@ subroutine init_atm_static(mesh) ! ! Interpolate LU_INDEX ! + surface_input_select1: select case(trim(config_landuse_data)) + case('USGS') + geog_sub_path = 'landuse_30s/' + case('MODIFIED_IGBP_MODIS_NOAH') + geog_sub_path = 'modis_landuse_20class_30s/' + case default + write(0,*) '*****************************************************************' + write(0,*) 'Invalid land use dataset '''//trim(config_landuse_data)//''' selected for config_landuse_data' + write(0,*) ' Possible options are: ''USGS'', ''MODIFIED_IGBP_MODIS_NOAH''' + write(0,*) '*****************************************************************' + call mpas_dmpar_global_abort('Please correct the namelist.') + end select surface_input_select1 nx = 1200 ny = 1200 nz = 1 @@ -180,9 +296,9 @@ subroutine init_atm_static(mesh) wordsize = 1 scalefactor = 1.0 allocate(rarray(nx,ny,nz)) - allocate(ncat(24,mesh%nCells)) + allocate(ncat(ismax_lu,nCells)) ncat(:,:) = 0 - mesh%lu_index%array(:) = 0.0 + lu_index(:) = 0.0 do jTileStart = 1,20401,ny jTileEnd = jTileStart + ny - 1 @@ -190,24 +306,29 @@ subroutine init_atm_static(mesh) do iTileStart = 1,42001,nx iTileEnd = iTileStart + nx - 1 write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'landuse_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd + trim(geog_sub_path),iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd write(0,*) trim(fname) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname, dminfo) + call init_atm_check_read_error(istatus, fname) iPoint = 1 do j=1,ny do i=1,nx +! +! The MODIS dataset appears to have zeros at the South Pole, possibly other places, too +! +if (rarray(i,j,1) == 0) cycle + lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333 lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333 lat_pt = lat_pt * PI / 180.0 lon_pt = lon_pt * PI / 180.0 - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, & - mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, & - mesh%latCell%array,mesh%lonCell%array) + iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & + nEdgesOnCell,cellsOnCell, & + latCell,lonCell) ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 end do end do @@ -215,11 +336,11 @@ subroutine init_atm_static(mesh) end do end do - do iCell = 1,mesh%nCells - mesh%lu_index%array(iCell) = 1 - do i = 2,24 - if(ncat(i,iCell) > ncat(mesh%lu_index%array(iCell),iCell)) then - mesh%lu_index%array(iCell) = i + do iCell = 1,nCells + lu_index(iCell) = 1 + do i = 2,ismax_lu + if(ncat(i,iCell) > ncat(lu_index(iCell),iCell)) then + lu_index(iCell) = i end if end do end do @@ -239,9 +360,9 @@ subroutine init_atm_static(mesh) wordsize = 1 scalefactor = 1.0 allocate(rarray(nx,ny,nz)) - allocate(ncat(16,mesh%nCells)) + allocate(ncat(16,nCells)) ncat(:,:) = 0 - mesh%soilcat_top%array(:) = 0.0 + soilcat_top(:) = 0.0 do jTileStart = 1,20401,ny jTileEnd = jTileStart + ny - 1 @@ -254,7 +375,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname, dminfo) + call init_atm_check_read_error(istatus, fname) iPoint = 1 do j=1,ny @@ -264,9 +385,9 @@ subroutine init_atm_static(mesh) lat_pt = lat_pt * PI / 180.0 lon_pt = lon_pt * PI / 180.0 - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, & - mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, & - mesh%latCell%array,mesh%lonCell%array) + iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & + nEdgesOnCell,cellsOnCell, & + latCell,lonCell) ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 end do end do @@ -274,11 +395,11 @@ subroutine init_atm_static(mesh) end do end do - do iCell = 1,mesh%nCells - mesh%soilcat_top%array(iCell) = 1 + do iCell = 1,nCells + soilcat_top(iCell) = 1 do i = 2,16 - if(ncat(i,iCell) > ncat(mesh%soilcat_top%array(iCell),iCell)) then - mesh%soilcat_top%array(iCell) = i + if(ncat(i,iCell) > ncat(soilcat_top(iCell),iCell)) then + soilcat_top(iCell) = i end if end do end do @@ -298,9 +419,9 @@ subroutine init_atm_static(mesh) wordsize = 1 scalefactor = 1.0 allocate(rarray(nx,ny,nz)) - allocate(ncat(16,mesh%nCells)) + allocate(ncat(16,nCells)) ncat(:,:) = 0 - mesh%soilcat_bot%array(:) = 0.0 + soilcat_bot(:) = 0.0 do jTileStart = 1,20401,ny jTileEnd = jTileStart + ny - 1 @@ -313,7 +434,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname, dminfo) + call init_atm_check_read_error(istatus, fname) iPoint = 1 do j=1,ny @@ -323,9 +444,9 @@ subroutine init_atm_static(mesh) lat_pt = lat_pt * PI / 180.0 lon_pt = lon_pt * PI / 180.0 - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, & - mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, & - mesh%latCell%array,mesh%lonCell%array) + iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & + nEdgesOnCell,cellsOnCell, & + latCell,lonCell) ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 end do end do @@ -333,11 +454,11 @@ subroutine init_atm_static(mesh) end do end do - do iCell =1, mesh%nCells - mesh%soilcat_bot%array(iCell) = 1 + do iCell =1,nCells + soilcat_bot(iCell) = 1 do i = 2,16 - if(ncat(i,iCell) > ncat(mesh%soilcat_bot%array(iCell),iCell)) then - mesh%soilcat_bot%array(iCell) = i + if(ncat(i,iCell) > ncat(soilcat_bot(iCell),iCell)) then + soilcat_bot(iCell) = i end if end do end do @@ -349,27 +470,27 @@ subroutine init_atm_static(mesh) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! KLUDGE TO FIX SOIL TYPE OVER ANTARCTICA !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - where (mesh%lu_index%array == 24) mesh%soilcat_top%array = 16 - where (mesh%lu_index%array == 24) mesh%soilcat_bot%array = 16 + where (lu_index == isice_lu) soilcat_top = 16 + where (lu_index == isice_lu) soilcat_bot = 16 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! CORRECT INCONSISTENT SOIL AND LAND USE DATA !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do iCell = 1,mesh%nCells - if (mesh%lu_index%array(iCell) == 16 .or. & - mesh%soilcat_top%array(iCell) == 14 .or. & - mesh%soilcat_bot%array(iCell) == 14) then - if (mesh%lu_index%array(iCell) /= 16) then + do iCell = 1,nCells + if (lu_index(iCell) == iswater_lu .or. & + soilcat_top(iCell) == 14 .or. & + soilcat_bot(iCell) == 14) then + if (lu_index(iCell) /= iswater_lu) then write(0,*) 'Turning lu_index into water at ', iCell - mesh%lu_index%array(iCell) = 16 + lu_index(iCell) = iswater_lu end if - if (mesh%soilcat_top%array(iCell) /= 14) then + if (soilcat_top(iCell) /= 14) then write(0,*) 'Turning soilcat_top into water at ', iCell - mesh%soilcat_top%array(iCell) = 14 + soilcat_top(iCell) = 14 end if - if (mesh%soilcat_bot%array(iCell) /= 14) then + if (soilcat_bot(iCell) /= 14) then write(0,*) 'Turning soilcat_bot into water at ', iCell - mesh%soilcat_bot%array(iCell) = 14 + soilcat_bot(iCell) = 14 end if end if end do @@ -378,9 +499,9 @@ subroutine init_atm_static(mesh) ! ! Derive LANDMASK ! - mesh%landmask%array(:) = 0 - do iCell=1, mesh%nCells - if (mesh%lu_index%array(iCell) /= 16) mesh%landmask%array(iCell) = 1 + landmask(:) = 0 + do iCell=1, nCells + if (lu_index(iCell) /= iswater_lu) landmask(iCell) = 1 end do write(0,*) '--- end interpolate LANDMASK' @@ -397,7 +518,7 @@ subroutine init_atm_static(mesh) scalefactor = 0.01 allocate(rarray(nx,ny,nz)) allocate(soiltemp_1deg(-2:363,-2:183)) - mesh%soiltemp%array(:) = 0.0 + soiltemp(:) = 0.0 call map_set(PROJ_LATLON, proj, & latinc = 1.0_RKIND, & @@ -413,7 +534,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned, endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname, dminfo) + call init_atm_check_read_error(istatus, fname) soiltemp_1deg(-2:180,-2:183) = rarray(1:183,1:186,1) write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & @@ -422,7 +543,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname, len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) soiltemp_1deg(181:363,-2:183) = rarray(4:186,1:186,1) interp_list(1) = FOUR_POINT @@ -431,11 +552,11 @@ subroutine init_atm_static(mesh) interp_list(4) = SEARCH interp_list(5) = 0 - do iCell = 1,mesh%nCells + do iCell = 1,nCells - if(mesh%landmask%array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) if(x < 0.5) then lon = lon + 360.0 @@ -446,10 +567,10 @@ subroutine init_atm_static(mesh) end if if (y < 1.0) y = 1.0 if (y > 179.0) y = 179.0 - mesh%soiltemp%array(iCell) = interp_sequence(x,y,1,soiltemp_1deg,-2,363,-2,183, & + soiltemp(iCell) = interp_sequence(x,y,1,soiltemp_1deg,-2,363,-2,183, & 1,1,0.0_RKIND,interp_list,1) else - mesh%soiltemp%array(iCell) = 0.0 + soiltemp(iCell) = 0.0 end if end do @@ -470,7 +591,7 @@ subroutine init_atm_static(mesh) scalefactor = 1.0 allocate(rarray(nx,ny,nz)) allocate(maxsnowalb(-2:363,-2:183)) - mesh%snoalb%array(:) = 0.0 + snoalb(:) = 0.0 call map_set(PROJ_LATLON, proj, & latinc = 1.0_RKIND, & @@ -486,7 +607,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) maxsnowalb(-2:180,-2:183) = rarray(1:183,1:186,1) write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & @@ -495,7 +616,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname, dminfo) + call init_atm_check_read_error(istatus, fname) maxsnowalb(181:363,-2:183) = rarray(4:186,1:186,1) interp_list(1) = FOUR_POINT @@ -504,11 +625,11 @@ subroutine init_atm_static(mesh) interp_list(4) = SEARCH interp_list(5) = 0 - do iCell = 1,mesh%nCells + do iCell = 1,nCells - if(mesh%landmask%array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) if(x < 0.5) then lon = lon + 360.0 @@ -519,14 +640,14 @@ subroutine init_atm_static(mesh) end if if (y < 1.0) y = 1.0 if (y > 179.0) y = 179.0 - mesh%snoalb%array(iCell) = interp_sequence(x,y,1,maxsnowalb,-2,363,-2,183, & + snoalb(iCell) = interp_sequence(x,y,1,maxsnowalb,-2,363,-2,183, & 1,1,0.0_RKIND,interp_list,1) else - mesh%snoalb%array(iCell) = 0.0 + snoalb(iCell) = 0.0 end if end do - mesh%snoalb%array(:) = mesh%snoalb%array(:) / 100.0 + snoalb(:) = snoalb(:) / 100.0 deallocate(rarray) deallocate(maxsnowalb) write(0,*) '--- end interpolate SNOALB' @@ -544,7 +665,7 @@ subroutine init_atm_static(mesh) scalefactor = 1.0 allocate(rarray(nx,ny,nz)) allocate(vegfra(-2:2503,-2:1253,12)) - mesh%greenfrac%array(:,:) = 0.0 + greenfrac(:,:) = 0.0 call map_set(PROJ_LATLON, proj, & latinc = 0.144_RKIND, & @@ -560,7 +681,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12) write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & @@ -569,14 +690,14 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12) - do iCell = 1,mesh%nCells + do iCell = 1,nCells - if (mesh%landmask%array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + if (landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) if(x < 0.5) then lon = lon + 360.0 @@ -588,14 +709,14 @@ subroutine init_atm_static(mesh) if (y < 1.0) y = 1.0 if (y > 1249.0) y = 1249.0 do k = 1,12 - mesh%greenfrac%array(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, & + greenfrac(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, & 1,12,-1.e30_RKIND,interp_list,1) end do else - mesh%greenfrac%array(:,iCell) = 0.0 + greenfrac(:,iCell) = 0.0 end if - mesh%shdmin%array(iCell) = minval(mesh%greenfrac%array(:,iCell)) - mesh%shdmax%array(iCell) = maxval(mesh%greenfrac%array(:,iCell)) + shdmin(iCell) = minval(greenfrac(:,iCell)) + shdmax(iCell) = maxval(greenfrac(:,iCell)) end do deallocate(rarray) @@ -615,7 +736,7 @@ subroutine init_atm_static(mesh) scalefactor = 1.0 allocate(rarray(nx,ny,nz)) allocate(vegfra(-2:2503,-2:1253,12)) - mesh%albedo12m%array(:,:) = 0.0 + albedo12m(:,:) = 0.0 call map_set(PROJ_LATLON, proj, & latinc = 0.144_RKIND, & @@ -631,7 +752,7 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor, wordsize, istatus) - call init_atm_check_read_error(istatus,fname, dminfo) + call init_atm_check_read_error(istatus,fname) vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12) write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & @@ -640,14 +761,14 @@ subroutine init_atm_static(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12) - do iCell = 1,mesh%nCells + do iCell = 1,nCells - if (mesh%landmask%array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + if (landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) if(x < 0.5) then lon = lon + 360.0 @@ -659,11 +780,11 @@ subroutine init_atm_static(mesh) if (y < 1.0) y = 1.0 if (y > 1249.0) y = 1249.0 do k = 1,12 - mesh%albedo12m%array(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, & + albedo12m(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, & 1,12,0.0_RKIND,interp_list,1) end do else - mesh%albedo12m%array(:,iCell) = 8.0 + albedo12m(:,iCell) = 8.0 end if end do deallocate(rarray) @@ -674,20 +795,28 @@ subroutine init_atm_static(mesh) end subroutine init_atm_static !================================================================================================== - subroutine init_atm_static_orogwd(mesh) + subroutine init_atm_static_orogwd(mesh, dims, configs) !================================================================================================== !inout arguments: - type(mesh_type),intent(inout):: mesh + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs !local variables: type(proj_info):: proj - type(dm_info),pointer :: dminfo - character(len=StrKIND):: mess - character(len=StrKIND):: fname - character(len=StrKIND):: dir_gwdo - character(len=StrKIND+1):: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash + character(len=StrKIND) :: mess + character(len=StrKIND) :: fname + character(len=StrKIND) :: dir_gwdo + character(len=StrKIND), pointer :: config_geog_data_path + character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash + + integer, pointer :: nCells, nEdges, maxEdges + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:), pointer :: landmask integer:: nx,ny,nz integer:: endian,isigned,istatus,wordsize @@ -706,14 +835,42 @@ subroutine init_atm_static_orogwd(mesh) real(kind=RKIND):: mindcEdge,maxdcEdge real(kind=RKIND),dimension(:,:),allocatable:: xarray + real(kind=RKIND), dimension(:), pointer :: latCell, lonCell + real(kind=RKIND), dimension(:), pointer :: meshDensity + real(kind=RKIND), dimension(:), pointer :: dcEdge + real(kind=RKIND), dimension(:), pointer :: varsso + real(kind=RKIND), dimension(:), pointer :: con, oa1, oa2, oa3, oa4, ol1, ol2, ol3, ol4, var2d + + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_dimension(dims, 'nEdges', nEdges) + call mpas_pool_get_dimension(dims, 'maxEdges', maxEdges) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'varsso', varsso) + call mpas_pool_get_array(mesh, 'meshDensity', meshDensity) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'con', con) + call mpas_pool_get_array(mesh, 'oa1', oa1) + call mpas_pool_get_array(mesh, 'oa2', oa2) + call mpas_pool_get_array(mesh, 'oa3', oa3) + call mpas_pool_get_array(mesh, 'oa4', oa4) + call mpas_pool_get_array(mesh, 'ol1', ol1) + call mpas_pool_get_array(mesh, 'ol2', ol2) + call mpas_pool_get_array(mesh, 'ol3', ol3) + call mpas_pool_get_array(mesh, 'ol4', ol4) + call mpas_pool_get_array(mesh, 'var2d', var2d) -!-------------------------------------------------------------------------------------------------- - - dminfo => mesh % block % domain % dminfo write(0,*) write(0,*) '--- enter subroutine init_atm_static_orogwd:' + call mpas_pool_get_config(configs, 'config_geog_data_path', config_geog_data_path) + write(geog_data_path, '(a)') config_geog_data_path i = len_trim(geog_data_path) if (geog_data_path(i:i) /= '/') then @@ -722,7 +879,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate VARSSO: - mesh%varsso%array(:) = 0.0_RKIND + varsso(:) = 0.0_RKIND nx = 600 ny = 600 nz = 1 @@ -739,7 +896,7 @@ subroutine init_atm_static_orogwd(mesh) known_lon = -179.99583 allocate(rarray(nx,ny,nz)) - allocate(nhs(mesh%nCells)) + allocate(nhs(nCells)) nhs(:) = 0 rarray(:,:,:) = 0._RKIND do jTileStart = 1,13801,ny @@ -753,7 +910,7 @@ subroutine init_atm_static_orogwd(mesh) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) iPoint = 1 do j = 1,ny @@ -763,10 +920,10 @@ subroutine init_atm_static_orogwd(mesh) lat_pt = lat_pt * PI / 180.0 lon_pt = lon_pt * PI / 180.0 - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,mesh%nCells,mesh%maxEdges, & - mesh%nEdgesOnCell%array,mesh%cellsOnCell%array, & - mesh%latCell%array,mesh%lonCell%array) - mesh%varsso%array(iPoint) = mesh%varsso%array(iPoint) + rarray(i,j,1) + iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & + nEdgesOnCell,cellsOnCell, & + latCell,lonCell) + varsso(iPoint) = varsso(iPoint) + rarray(i,j,1) nhs(iPoint) = nhs(iPoint) + 1 enddo enddo @@ -774,9 +931,9 @@ subroutine init_atm_static_orogwd(mesh) enddo enddo - do iCell = 1,mesh%nCells + do iCell = 1,nCells if(nhs(iCell) .gt. 0) & - mesh%varsso%array(iCell) = mesh%varsso%array(iCell) / real(nhs(iCell)) + varsso(iCell) = varsso(iCell) / real(nhs(iCell)) enddo deallocate(rarray) deallocate(nhs) @@ -784,10 +941,10 @@ subroutine init_atm_static_orogwd(mesh) !... statistic fields needed for the parameterization of gravity wavwe drag over orography. The !input directory depends on the mesh resolution, and the mesh must be a uniform mesh. - minMeshD = minval(mesh%meshDensity%array(1:mesh%nCells)) - maxMeshD = maxval(mesh%meshDensity%array(1:mesh%nCells)) - mindcEdge = minval(mesh%dcEdge%array(1:mesh%nEdges)) - maxdcEdge = maxval(mesh%dcEdge%array(1:mesh%nEdges)) + minMeshD = minval(meshDensity(1:nCells)) + maxMeshD = maxval(meshDensity(1:nCells)) + mindcEdge = minval(dcEdge(1:nEdges)) + maxdcEdge = maxval(dcEdge(1:nEdges)) write(0,*) write(0,*) 'BEGIN INTERPOLATION OF STATISTICAL FIELDS FOR GRAVITY WAVE DRAG OVER OROGRAPHY' @@ -825,7 +982,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate CON: ! - mesh%con%array(:) = 0.0_RKIND + con(:) = 0.0_RKIND con_select: select case(dir_gwdo) case("orogwd_2deg") @@ -895,7 +1052,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -912,13 +1069,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % con % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + con(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -928,7 +1085,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate OA1: ! - mesh%oa1%array(:) = 0.0_RKIND + oa1(:) = 0.0_RKIND oa1_select: select case(dir_gwdo) case("orogwd_2deg") @@ -998,7 +1155,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1015,13 +1172,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % oa1 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + oa1(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1030,7 +1187,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate OA2: - mesh%oa2%array(:) = 0.0_RKIND + oa2(:) = 0.0_RKIND oa2_select: select case(dir_gwdo) case("orogwd_2deg") @@ -1100,7 +1257,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1117,13 +1274,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % oa2 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + oa2(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1133,7 +1290,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate OA3: ! - mesh%oa3%array(:) = 0.0_RKIND + oa3(:) = 0.0_RKIND oa3_select: select case(dir_gwdo) case("orogwd_2deg") @@ -1203,7 +1360,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1220,13 +1377,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % oa3 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + oa3(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1236,7 +1393,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate OA4: ! - mesh%oa4%array(:) = 0.0_RKIND + oa4(:) = 0.0_RKIND oa4_select: select case(dir_gwdo) case("orogwd_2deg") @@ -1306,7 +1463,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1323,13 +1480,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % oa4 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + oa4(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1339,7 +1496,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate OL1: ! - mesh%ol1%array(:) = 0.0_RKIND + ol1(:) = 0.0_RKIND ol1_select: select case(dir_gwdo) case("orogwd_2deg") @@ -1409,7 +1566,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1426,13 +1583,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % ol1 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + ol1(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1442,7 +1599,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate OL2: ! - mesh%ol2%array(:) = 0.0_RKIND + ol2(:) = 0.0_RKIND ol2_select: select case(dir_gwdo) case("orogwd_2deg") @@ -1512,7 +1669,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1529,13 +1686,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % ol2 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + ol2(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1545,7 +1702,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate OL3: ! - mesh%ol3%array(:) = 0.0_RKIND + ol3(:) = 0.0_RKIND ol3_select: select case(dir_gwdo) case("orogwd_2deg") @@ -1615,7 +1772,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1632,13 +1789,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % ol3 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + ol3(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1648,7 +1805,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate OL4: ! - mesh%ol4%array(:) = 0.0_RKIND + ol4(:) = 0.0_RKIND ol4_select: select case(dir_gwdo) case("orogwd_2deg") @@ -1718,7 +1875,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1735,13 +1892,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % ol4 % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + ol4(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1751,7 +1908,7 @@ subroutine init_atm_static_orogwd(mesh) ! ! Interpolate VAR2D: ! - mesh%var2d%array(:) = 0.0_RKIND + var2d(:) = 0.0_RKIND var2d_select: select case(dir_gwdo) case("orogwd_2deg") @@ -1822,7 +1979,7 @@ subroutine init_atm_static_orogwd(mesh) allocate(rarray(nx,ny,nz)) call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname,dminfo) + call init_atm_check_read_error(istatus,fname) xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) call map_set(PROJ_LATLON, proj, & @@ -1839,13 +1996,13 @@ subroutine init_atm_static_orogwd(mesh) interp_list(4) = AVERAGE4 interp_list(5) = 0 - do iCell = 1,mesh%nCells - if(mesh % landmask % array(iCell) == 1) then - lat = mesh % latCell % array(iCell) * DEG_PER_RAD - lon = mesh % lonCell % array(iCell) * DEG_PER_RAD + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) - mesh % var2d % array(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) + var2d(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & + 0.0_RKIND,interp_list,1) endif enddo deallocate(rarray) @@ -1855,17 +2012,15 @@ subroutine init_atm_static_orogwd(mesh) end subroutine init_atm_static_orogwd !================================================================================================== - subroutine init_atm_check_read_error(istatus, fname, dminfo) + subroutine init_atm_check_read_error(istatus, fname) !================================================================================================== implicit none integer, intent(in) :: istatus character (len=*), intent(in) :: fname - type (dm_info), intent(in) :: dminfo if (istatus /= 0) then - write(0,*) 'ERROR: Could not read file '//trim(fname) - call mpas_dmpar_abort(dminfo) + call mpas_dmpar_global_abort('ERROR: Could not read file '//trim(fname)) end if end subroutine init_atm_check_read_error diff --git a/src/core_init_atmosphere/mpas_init_atm_surface.F b/src/core_init_atmosphere/mpas_init_atm_surface.F index 60cf9a11f5..4c1f72f5b0 100644 --- a/src/core_init_atmosphere/mpas_init_atm_surface.F +++ b/src/core_init_atmosphere/mpas_init_atm_surface.F @@ -7,9 +7,8 @@ ! !================================================================================================== module mpas_init_atm_surface - use mpas_configure +! use mpas_configure use mpas_grid_types - use mpas_io_output use mpas_timekeeping use mpas_timer @@ -19,101 +18,116 @@ module mpas_init_atm_surface implicit none private - public:: init_atm_case_sfc,interp_sfc_to_MPAS + public :: init_atm_case_sfc, interp_sfc_to_MPAS - integer, parameter :: R4KIND = selected_real_kind(6) contains + !================================================================================================== - subroutine init_atm_case_sfc(domain,dminfo,mesh,fg,state) + subroutine init_atm_case_sfc(domain, dminfo, stream_manager, mesh, fg, state, dims, configs) !================================================================================================== -!input arguments: - type(domain_type), intent(inout):: domain - type(dm_info), intent(in) :: dminfo - type(mesh_type), intent(inout) :: mesh - type(fg_type), intent(inout) :: fg - type (state_type), intent(inout):: state + use mpas_stream_manager -!local variables: - type(MPAS_Clock_type) :: fg_clock - type(MPAS_Time_type) :: start_time,stop_time,curr_time - type(MPAS_TimeInterval_type):: fg_interval + implicit none - type(io_output_object):: sfc_update_obj +!input arguments: + type (domain_type), intent(inout) :: domain + type (dm_info), intent(in) :: dminfo + type (MPAS_streamManager_type), intent(inout) :: stream_manager + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: fg + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs +!local variables: + type (MPAS_Time_type) :: curr_time, stop_time character(len=StrKIND) :: timeString + character(len=StrKIND), pointer :: config_sfc_prefix + character(len=StrKIND), pointer :: xtime + integer :: ierr + + !================================================================================================== -!set up clock to step through all intermediate file dates to be processed: - call mpas_set_time(start_time, dateTimeString=trim(config_start_time)) - call mpas_set_time(stop_time, dateTimeString=trim(config_stop_time)) - call mpas_set_timeInterval(fg_interval, S=config_fg_interval) - call mpas_create_clock(fg_clock, start_time, fg_interval, stopTime=stop_time) -!initialize the output file - sfc_update_obj % time = 1 - sfc_update_obj % filename = trim(config_sfc_update_name) + call mpas_pool_get_config(configs, 'config_sfc_prefix', config_sfc_prefix) - call mpas_output_state_init(sfc_update_obj, domain, "SFC") + call mpas_pool_get_array(state, 'xtime', xtime) !loop over all times: - curr_time = mpas_get_clock_time(fg_clock, MPAS_NOW) + curr_time = mpas_get_clock_time(domain % clock, MPAS_NOW) + stop_time = mpas_get_clock_time(domain % clock, MPAS_STOP_TIME) do while (curr_time <= stop_time) call mpas_get_time(curr_time, dateTimeString=timeString) + xtime = timeString + ! write(0,*) 'Processing ',trim(config_sfc_prefix)//':'//timeString(1:13) !read the sea-surface temperature and sea-ice data from the surface file, and interpolate the !data to the MPAS grid: - call interp_sfc_to_MPAS(timeString(1:13),mesh,fg,dminfo) + call interp_sfc_to_MPAS(timeString(1:13), mesh, fg, dims, dminfo, config_sfc_prefix) !write the interpolated SST/SKINTEMP field as a new time slice in the MPAS output file: - call mpas_output_state_for_domain(sfc_update_obj, domain, sfc_update_obj % time) - sfc_update_obj % time = sfc_update_obj % time + 1 + call mpas_stream_mgr_write(stream_manager, streamID='surface', ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='surface', direction=MPAS_STREAM_OUTPUT, ierr=ierr) - call mpas_advance_clock(fg_clock) - curr_time = mpas_get_clock_time(fg_clock, MPAS_NOW) + call mpas_advance_clock(domain % clock) + curr_time = mpas_get_clock_time(domain % clock, MPAS_NOW) - call mpas_get_time(curr_time, dateTimeString=timeString) - state % xtime % scalar = timeString + end do - enddo - - call mpas_output_state_finalize(sfc_update_obj, dminfo) - end subroutine init_atm_case_sfc !================================================================================================== - subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo) + subroutine interp_sfc_to_MPAS(timeString, mesh, fg, dims, dminfo, config_sfc_prefix) !================================================================================================== + use mpas_dmpar + + implicit none + !input arguments: - character(len=*),intent(in):: timeString - type(mesh_type), intent(in):: mesh - type(dm_info),intent(in) :: dminfo + character(len=*), intent(in) :: timeString + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (dm_info), intent(in) :: dminfo + character(len=*), intent(in) :: config_sfc_prefix !inout arguments: - type(fg_type), intent(inout):: fg + type (mpas_pool_type), intent(inout) :: fg + !local variables: type(met_data) :: field !real*4 meteorological data. - integer:: istatus - integer:: masked - integer,dimension(5):: interp_list - integer,dimension(:),pointer:: mask_array + integer :: istatus + integer :: masked + integer, dimension(5) :: interp_list + integer, dimension(:), pointer :: mask_array logical :: have_landmask - real(kind=RKIND):: fillval,maskval,msgval - real(kind=RKIND),dimension(:,:),allocatable:: maskslab + real(kind=RKIND) :: fillval, maskval, msgval + real(kind=RKIND), dimension(:,:), allocatable :: maskslab - real(kind=RKIND), dimension(:), pointer:: destField1d + integer, dimension(:), pointer :: landmask + real(kind=RKIND), dimension(:), pointer :: destField1d + real(kind=RKIND), dimension(:), pointer :: sst, xice + + integer, pointer :: nCells !================================================================================================== - mask_array => mesh % landmask % array + + call mpas_pool_get_array(mesh, 'landmask', mask_array) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(fg, 'sst', sst) + call mpas_pool_get_array(fg, 'xice', xice) + + call mpas_pool_get_dimension(dims, 'nCells', nCells) !open intermediate file: call read_met_init(trim(config_sfc_prefix),.false.,timeString,istatus) @@ -125,7 +139,7 @@ subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo) call mpas_dmpar_abort(dminfo) else write(0,*) 'Processing file ',trim(config_sfc_prefix)//':'//timeString(1:13) - endif + end if !scan through all fields in the file, looking for the LANDSEA field: have_landmask = .false. @@ -142,10 +156,10 @@ subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo) maskslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny) maskslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny) ! write(0,*) 'minval, maxval of LANDSEA = ', minval(maskslab), maxval(maskslab) - endif + end if deallocate(field % slab) call read_next_met_field(field,istatus) - enddo + end do call read_met_close() !read sea-surface temperatures and seaice data. open intermediate file: @@ -156,13 +170,13 @@ subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo) trim(config_sfc_prefix)//':'//timeString(1:13) write(0,*) '********************************************************************************' call mpas_dmpar_abort(dminfo) - endif + end if if(.not. have_landmask) then write(0,*) '********************************************************************************' write(0,*) 'Landsea mask not available from the surface file ' write(0,*) '********************************************************************************' - endif + end if !scan through all fields in the file, looking for the SST,SKINTEMP, or SEAICE field: call read_next_met_field(field,istatus) @@ -171,8 +185,8 @@ subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo) !sea-surface data: if(index(field % field, 'SKINTEMP') /= 0 .or. index(field % field, 'SST') /= 0) then ! write(0,*) '... Processing SST:' - fg % sst % array(1:mesh%nCells) = 0.0_RKIND - destField1d => fg % sst % array + sst(1:nCells) = 0.0_RKIND + destField1d => sst !interpolation to the MPAS grid: interp_list(1) = FOUR_POINT @@ -183,21 +197,21 @@ subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo) maskval = -1.0_RKIND fillval = 0.0_RKIND if(have_landmask) then - call interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + call interp_to_MPAS(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & mask_array,maskslab) else - call interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + call interp_to_MPAS(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & mask_array) - endif + end if !field%slab was allocated in the subroutine read_next_met_field deallocate(field%slab) !sea-ice data: - elseif(index(field % field, 'SEAICE') /= 0) then + else if(index(field % field, 'SEAICE') /= 0) then ! write(0,*) '... Processing SEAICE:' - fg % xice % array(1:mesh%nCells) = 0.0_RKIND - destField1d => fg % xice % array + xice(1:nCells) = 0.0_RKIND + destField1d => xice !interpolation to the MPAS grid: interp_list(1) = FOUR_POINT @@ -209,12 +223,12 @@ subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo) maskval = 1.0_RKIND fillval = 0.0_RKIND if(have_landmask) then - call interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + call interp_to_MPAS(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & mask_array,maskslab) else - call interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + call interp_to_MPAS(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & mask_array) - endif + end if !field%slab was allocated in the subroutine read_next_met_field deallocate(field%slab) @@ -222,54 +236,59 @@ subroutine interp_sfc_to_MPAS(timeString,mesh,fg,dminfo) else deallocate(field%slab) - endif + end if call read_next_met_field(field,istatus) - enddo + end do !close intermediate file: call read_met_close() if(allocated(maskslab)) deallocate(maskslab) !freeze really cold oceans: - where(fg%sst%array.lt.271.0_RKIND .and. mesh%landmask%array.eq.0) fg%xice%array = 1.0_RKIND + where (sst < 271.0_RKIND .and. landmask == 0) xice = 1.0_RKIND !limit XICE to values between 0 and 1. Although the input meteorological field is between 0. and 1. !interpolation to the MPAS grid can yield values of XiCE less than 0. and greater than 1.: - where (fg%xice%array < 0._RKIND) fg%xice%array = 0._RKIND - where (fg%xice%array > 1._RKIND) fg%xice%array = 1._RKIND + where (xice < 0._RKIND) xice = 0._RKIND + where (xice > 1._RKIND) xice = 1._RKIND end subroutine interp_sfc_to_MPAS !================================================================================================== - subroutine interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + subroutine interp_to_MPAS(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & mask_array,maskslab) !================================================================================================== !input arguments: - type(mesh_type),intent(in):: mesh - type(met_data),intent(in) :: field !real*4 meteorological data. + type (mpas_pool_type), intent(in) :: mesh + integer, intent(in) :: nCells + type (met_data), intent(in) :: field !real*4 meteorological data. - integer,intent(in):: masked - integer,dimension(5),intent(in):: interp_list - integer,dimension(:),intent(in),pointer:: mask_array + integer, intent(in) :: masked + integer, dimension(5), intent(in) :: interp_list + integer, dimension(:), intent(in), pointer :: mask_array - real(kind=RKIND),intent(in):: fillval,maskval,msgval - real(kind=RKIND),intent(in),dimension(*),optional:: maskslab + real(kind=RKIND), intent(in) :: fillval, maskval, msgval + real(kind=RKIND), intent(in), dimension(*), optional :: maskslab !inout arguments: - real(kind=RKIND),intent(inout),dimension(:),pointer:: destField1d + real(kind=RKIND), intent(inout), dimension(:), pointer :: destField1d !local variables: - type(proj_info):: proj - integer:: i,nInterpPoints - real(kind=RKIND):: lat,lon,x,y - real(kind=RKIND),dimension(:,:),allocatable:: rslab + type(proj_info) :: proj + integer :: i, nInterpPoints + real(kind=RKIND) :: lat,lon,x,y + real(kind=RKIND), dimension(:,:), allocatable :: rslab - real(kind=RKIND),dimension(:),pointer:: latPoints,lonPoints + real(kind=RKIND), dimension(:), pointer :: latPoints, lonPoints + real(kind=RKIND), dimension(:), pointer :: latCell, lonCell !-------------------------------------------------------------------------------------------------- + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call map_init(proj) if(field % iproj == PROJ_LATLON) then call map_set(PROJ_LATLON, proj, & @@ -280,14 +299,14 @@ subroutine interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskv lat1 = real(field % startlat,RKIND), & lon1 = real(field % startlon,RKIND)) ! write(0,*) '--- The projection is PROJ_LATLON.' - elseif(field % iproj == PROJ_GAUSS) then + else if(field % iproj == PROJ_GAUSS) then call map_set(PROJ_GAUSS, proj, & nlat = nint(field % deltalat), & loninc = real(field % deltalon,RKIND), & lat1 = real(field % startlat,RKIND), & lon1 = real(field % startlon,RKIND)) ! write(0,*) '--- The projection is PROJ_GAUSS.' - elseif(field % iproj == PROJ_PS) then + else if(field % iproj == PROJ_PS) then call map_set(PROJ_PS, proj, & dx = real(field % dx,RKIND), & truelat1 = real(field % truelat1,RKIND), & @@ -297,11 +316,11 @@ subroutine interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskv lat1 = real(field % startlat,RKIND), & lon1 = real(field % startlon,RKIND)) ! write(0,*) '--- The projection is PROJ_PS.' - endif + end if - nInterpPoints = mesh % nCells - latPoints => mesh % latCell % array - lonPoints => mesh % lonCell % array + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell allocate(rslab(-2:field % nx+3, field % ny)) rslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny) @@ -319,27 +338,27 @@ subroutine interp_to_MPAS(mesh,field,destField1d,interp_list,msgval,masked,maskv call latlon_to_ij(proj, lat, lon, x, y) if(y <= 0.5) then y = 1.0 - elseif(y >= real(field%ny)+0.5) then + else if(y >= real(field%ny)+0.5) then y = real(field % ny) - endif + end if if(x < 0.5) then lon = lon + 360.0 call latlon_to_ij(proj, lat, lon, x, y) - elseif (x >= real(field%nx)+0.5) then + else if (x >= real(field%nx)+0.5) then lon = lon - 360.0 call latlon_to_ij(proj, lat, lon, x, y) - endif + end if if(present(maskslab)) then destField1d(i) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1, & msgval,interp_list,1,maskval=maskval,mask_array=maskslab) else destField1d(i) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1, & msgval,interp_list,1,maskval=maskval) - endif + end if else destField1d(i) = fillval - endif - enddo + end if + end do deallocate(rslab) end subroutine interp_to_MPAS diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 8b7691da07..5ba19beaae 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -15,6 +15,9 @@ all: core_landice core_landice: $(OBJS) ar -ru libdycore.a $(OBJS) +core_reg: + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml + mpas_li_mpas_core.o: mpas_li_time_integration.o \ mpas_li_setup.o \ mpas_li_velocity.o \ @@ -27,21 +30,28 @@ mpas_li_time_integration.o: mpas_li_time_integration_fe.o mpas_li_time_integration_fe.o: mpas_li_velocity.o \ mpas_li_tendency.o \ - mpas_li_diagnostic_vars.o + mpas_li_diagnostic_vars.o \ + mpas_li_setup.o -mpas_tendency.o: +mpas_li_tendency.o: mpas_li_setup.o mpas_li_diagnostic_vars.o: mpas_li_mask.o \ mpas_li_velocity.o -mpas_li_velocity.o: mpas_li_sia.o +mpas_li_velocity.o: mpas_li_sia.o \ + mpas_li_setup.o -mpas_li_sia.o: mpas_li_mask.o +mpas_li_sia.o: mpas_li_mask.o \ + mpas_li_setup.o -mpas_li_mask.o: +mpas_li_mask.o: mpas_li_setup.o clean: $(RM) *.o *.mod *.f90 libdycore.a + $(RM) Registry_processed.xml + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: $(RM) $@ $*.mod diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 2f9912a2d9..2ef5f5c8ef 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,10 @@ - + + + + + + - + + + + + - + + - + + - - - - + - + + + - - - - - - - - + - + - + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - + - - - - - - - - - + - + @@ -282,146 +391,150 @@ - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - - - + + + + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index f3e660cbde..bca3832160 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -109,8 +109,10 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! !----------------------------------------------------------------- type (block_type), pointer :: block - type (mesh_type), pointer :: mesh - type (state_type), pointer :: state + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool + type (field2DReal), pointer :: normalVelocityField, layerThicknessEdgeField + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional integer :: err_tmp !!! integer :: blockVertexMaskChanged, procVertexMaskChanged, anyVertexMaskChanged @@ -162,17 +164,14 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! LifeV does not support multiple blocks but the MPAS SIA could. block => domain % blocklist do while (associated(block)) - ! Mesh information - mesh => block % mesh - ! State at desired time level - state => block % state % time_levs(timeLevel) % state + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) !!! ! Assign the vertex-changed flag to each block !!! stateNew % anyVertexMaskChanged % scalar = anyVertexMaskChanged !!! !print *, 'anyVertexMaskChanged: ', anyVertexMaskChanged - - call li_velocity_solve(mesh, state, err_tmp) ! ****** Calculate Velocity ****** + call li_velocity_solve(meshPool, statePool, timeLevel, err_tmp) ! ****** Calculate Velocity ****** err = ior(err, err_tmp) block => block % next @@ -180,7 +179,9 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! update halos on velocity call mpas_timer_start("halo updates") - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(timeLevel) % state % normalVelocity) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocityField, timeLevel=timeLevel) + call mpas_dmpar_exch_halo_field(normalVelocityField) call mpas_timer_stop("halo updates") call mpas_timer_stop("velocity solve") @@ -198,16 +199,19 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! Still do this even if we didn't calculate velocity because on a restart these will be defined at the initial time. block => domain % blocklist do while (associated(block)) - mesh => block % mesh - state => block % state % time_levs(timeLevel) % state + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructZonal', uReconstructZonal, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructMeridional', uReconstructMeridional, timeLevel=timeLevel) - call mpas_reconstruct(mesh, state % normalVelocity % array,& - state % uReconstructX % array, & - state % uReconstructY % array, & - state % uReconstructZ % array, & - state % uReconstructZonal % array, & - state % uReconstructMeridional % array & - ) + call mpas_reconstruct(meshPool, normalVelocity, & + uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional ) block => block % next end do @@ -215,18 +219,18 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) block => domain % blocklist do while (associated(block)) - ! Mesh information - mesh => block % mesh - ! State at desired time level - state => block % state % time_levs(timeLevel) % state - call diagnostic_solve_after_velocity(mesh, state, err) ! Some diagnostic variables require velocity to compute + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call diagnostic_solve_after_velocity(meshPool, statePool, timeLevel, err) ! Some diagnostic variables require velocity to compute err = ior(err, err_tmp) block => block % next end do call mpas_timer_start("halo updates") - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(timeLevel) % state % layerThicknessEdge) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'layerThicknessEdge', layerThicknessEdgeField, timeLevel=timeLevel) + call mpas_dmpar_exch_halo_field(layerThicknessEdgeField) call mpas_timer_stop("halo updates") call mpas_timer_stop("calc. diagnostic vars except vel") @@ -294,14 +298,18 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! !----------------------------------------------------------------- type (block_type), pointer :: block - type (mesh_type), pointer :: mesh - type (state_type), pointer :: state - integer :: iCell, iLevel, nCells + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool real (kind=RKIND), dimension(:), pointer :: thickness, upperSurface, & - lowerSurface, bedTopography + lowerSurface, bedTopography, upperSurfaceVertex integer, dimension(:), pointer :: cellMask real (kind=RKIND), dimension(:,:), pointer :: layerThickness + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + type (field1DInteger), pointer :: cellMaskField, edgeMaskField, vertexMaskField + integer, pointer :: nCells + real (kind=RKIND), pointer :: config_sea_level, config_ice_density, config_ocean_density real (kind=RKIND) :: thisThk + integer :: iCell, iLevel integer :: err_tmp @@ -311,12 +319,11 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ block => domain % blocklist do while (associated(block)) ! Mesh information - mesh => block % mesh - ! State at desired time level - state => block % state % time_levs(timeLevel) % state + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) ! Calculate masks - needs to happen before calculating lower surface so we know where the ice is floating - call li_calculate_mask(mesh, state, err_tmp) + call li_calculate_mask(meshPool, statePool, timeLevel, err_tmp) err = ior(err, err_tmp) block => block % next @@ -324,9 +331,13 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Update halos on masks - the outermost cells/edges/vertices may be wrong for mask components that need neighbor information call mpas_timer_start("halo updates") - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(timeLevel) % state % cellMask) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(timeLevel) % state % edgeMask) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(timeLevel) % state % vertexMask) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'cellMask', cellMaskField, timeLevel=timeLevel) + call mpas_pool_get_field(statePool, 'edgeMask', edgeMaskField, timeLevel=timeLevel) + call mpas_pool_get_field(statePool, 'vertexMask', vertexMaskField, timeLevel=timeLevel) + call mpas_dmpar_exch_halo_field(cellMaskField) + call mpas_dmpar_exch_halo_field(edgeMaskField) + call mpas_dmpar_exch_halo_field(vertexMaskField) call mpas_timer_stop("halo updates") !!! ! Update beta before the velocity solve occurs, now that we have the new state and its mask. @@ -346,18 +357,23 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ block => domain % blocklist do while (associated(block)) - ! Mesh information - mesh => block % mesh - ! State at desired time level - state => block % state % time_levs(timeLevel) % state - - nCells = mesh % nCells - cellMask => state % cellMask % array - thickness => state % thickness % array - upperSurface => state % upperSurface % array - lowerSurface => state % lowerSurface % array - bedTopography => mesh % bedTopography % array - layerThickness => state % layerThickness % array + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) + call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) + + call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel=timeLevel) + call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) ! Lower surface is based on floatation for floating ice. For grounded ice (and non-ice areas) it is the bed. where ( li_mask_is_floating_ice(cellMask) ) @@ -375,9 +391,11 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Upper surface is the lower surface plus the thickness upperSurface(:) = lowerSurface(:) + thickness(:) + call cells_to_vertices_2dfield(meshPool, upperSurface, upperSurfaceVertex) ! (Needed only for SIA solver) + ! Note: the outer halo may be wrong, but that's ok as long as numhalos>1 because the velocity on the 0-halo will still be correct. ! Do vertical remapping of layerThickness and tracers - call vertical_remap(thickness, cellMask, mesh, layerThickness, state % tracers % array, err) + call vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) err = ior(err, err_tmp) block => block % next @@ -405,32 +423,31 @@ end subroutine diagnostic_solve_before_velocity !> This routine computes the diagnostic variables that require knowing velocity for land ice ! !----------------------------------------------------------------------- - subroutine diagnostic_solve_after_velocity(mesh, state, err)!{{{ + subroutine diagnostic_solve_after_velocity(meshPool, statePool, timeLevel, err) !----------------------------------------------------------------- ! ! input variables ! !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + integer, intent(in) :: timeLevel !< Input: Time level on which to calculate diagnostic variables !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - - type (state_type), intent(inout) :: & - state !< Input/Output: state for which to update diagnostic variables + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state for which to update diagnostic variables !----------------------------------------------------------------- ! ! output variables ! !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- @@ -440,19 +457,22 @@ subroutine diagnostic_solve_after_velocity(mesh, state, err)!{{{ !----------------------------------------------------------------- real (kind=RKIND), dimension(:,:), pointer :: layerThickness, layerThicknessEdge, normalVelocity integer, dimension(:,:), pointer :: cellsOnEdge - integer :: nVertLevels, iEdge, nEdges, cell1, cell2, k + integer, pointer :: nEdges, nVertLevels + character (len=StrKIND), pointer :: config_thickness_advection + integer :: iEdge, cell1, cell2, k real (kind=RKIND) :: VelSign err = 0 - nEdges = mesh % nEdges - nVertLevels = mesh % nVertLevels - cellsOnEdge => mesh % cellsOnEdge % array + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - layerThickness => state % layerThickness % array - normalVelocity => state % normalVelocity % array - layerThicknessEdge => state % layerThicknessEdge % array + call mpas_pool_get_config(liConfigs, 'config_thickness_advection', config_thickness_advection) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'layerThicknessEdge', layerThicknessEdge, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) ! Calculate h_edge. This is used by both thickness and tracer advection on the following Forward Euler time step. ! Note: FO-Upwind thickness advection does not explicitly use h_edge but a FO h_edge is implied. @@ -472,6 +492,8 @@ subroutine diagnostic_solve_after_velocity(mesh, state, err)!{{{ layerThicknessEdge(k,iEdge) = max(VelSign * layerThickness(k, cell1), VelSign * (-1.0_RKIND) * layerThickness(k, cell2)) ! + velocity goes from index 1 to 2 in the cellsOnEdge array. ! Doug does the calculation as: h_edge = max(VelSign, 0.0) * h1 - min(VelSign, 0.0) * h2 + !!! ! Calculate h on edges using second order + !!! layerThicknessEdge(k,iEdge) = 0.5_RKIND * (layerThickness(k, cell1) + layerThickness(k, cell2)) end do ! thickness_edge is not currently in registry and not currenly needed. If it is, uncomment the next line !h_edge = max(thickness(cell1), thickness(cell2)) @@ -509,7 +531,7 @@ end subroutine diagnostic_solve_after_velocity !> version until tracer advection exists!) ! !----------------------------------------------------------------------- - subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, mesh, err) + subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshPool, err) !----------------------------------------------------------------- ! ! input variables @@ -519,8 +541,8 @@ subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, mesh, e real (kind=RKIND), dimension(:), intent(in) :: & thickness !< Input: - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -529,10 +551,10 @@ subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, mesh, e !----------------------------------------------------------------- real (kind=RKIND), dimension(:,:), intent(inout) :: & - layerThickness !< Input: + layerThickness !< Input: real (kind=RKIND), dimension(:,:,:), intent(inout) :: & - tracers !< Input: + tracers !< Input: !----------------------------------------------------------------- ! @@ -554,19 +576,19 @@ subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, mesh, e real (kind=RKIND), dimension(:,:), allocatable :: layerInterfaceSigma_Input real (kind=RKIND), dimension(:,:,:), allocatable :: hTsum ! counters, mesh variables, index variables - integer :: nTracers, nCells, nVertLevels - integer :: iCell, k, k1, k2, nt + integer, pointer :: nCells, nVertLevels + integer :: nTracers, iCell, k, k1, k2, nt ! stuff for making calculations real(kind=RKIND) :: thisThk, zhi, zlo, hOverlap err = 0 - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) nTracers = size(tracers, 1) - layerThicknessFractions => mesh % layerThicknessFractions % array - layerInterfaceSigma => mesh % layerInterfaceSigma % array + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) allocate(recipThickness(nCells+1)) allocate(layerInterfaceSigma_Input(nVertLevels+1, nCells+1)) @@ -665,7 +687,7 @@ end subroutine vertical_remap_cism_loops !> rather than using if/where-statements. ! !----------------------------------------------------------------------- - subroutine vertical_remap(thickness, cellMask, mesh, layerThickness, tracers, err) + subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) !----------------------------------------------------------------- ! @@ -679,8 +701,8 @@ subroutine vertical_remap(thickness, cellMask, mesh, layerThickness, tracers, er integer, dimension(:), intent(in) :: & cellMask !< Input: mask for cells (needed for determining presence/absence of ice) - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -713,26 +735,24 @@ subroutine vertical_remap(thickness, cellMask, mesh, layerThickness, tracers, er real (kind=RKIND), dimension(:), allocatable :: layerInterfaceSigma_Input real (kind=RKIND), dimension(:,:), allocatable :: hTsum ! counters, mesh variables, index variables - integer :: nTracers, nCells, nVertLevels - integer :: iCell, k, k1, k2, nt + integer, pointer :: nCells, nVertLevels + integer :: nTracers, iCell, k, k1, k2, nt ! stuff for making calculations real(kind=RKIND) :: thisThk, zhi, zlo, hOverlap real(kind=RKIND), parameter :: eps = 1.0d-30 ! Make a tiny value so we don't corrupt any cells with ice err = 0 - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) nTracers = size(tracers, 1) - layerThicknessFractions => mesh % layerThicknessFractions % array - layerInterfaceSigma => mesh % layerInterfaceSigma % array - + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) allocate(layerInterfaceSigma_Input(nVertLevels+1)) allocate(hTsum(nTracers, nVertLevels)) - do iCell = 1, nCells ! Do all calculations column-wise thisThk = thickness(iCell) @@ -799,5 +819,79 @@ end subroutine vertical_remap +!*********************************************************************** +! +! subroutine cells_to_vertices_2dfield +! +!> \brief Converts a 2d scalar field from cells to vertices +!> \author Matt Hoffman +!> \date 21 May 2012 +!> \details +!> This routine converts a 2d scalar field from cells to vertices. +!----------------------------------------------------------------------- + subroutine cells_to_vertices_2dfield(meshPool, fieldCells, fieldVertices) + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + real (kind=RKIND), dimension(:), intent(in) :: & + fieldCells !< Input: field on cells + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + fieldVertices !< Input: field on vertices + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + integer, dimension(:,:), pointer :: cellsOnVertex + integer, pointer :: nVertices, vertexDegree + integer :: iCell, icell2, iVertex, cellIndex + real (kind=RKIND) :: fVertexAccum, baryweight, weightAccum + + ! Get needed items from mesh pool + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + + ! Calculate h on vertices using barycentric interpolation + do iVertex = 1, nVertices ! Loop over vertices + fVertexAccum = 0.0_RKIND + weightAccum = 0.0_RKIND + ! Loop over cells on this vertex + do iCell = 1, vertexDegree + cellIndex = cellsOnVertex(iCell, iVertex) + baryweight = 0.0_RKIND + do iCell2 = 1, vertexDegree + if (iCell2 /= icell) baryweight = baryweight + 0.5 * kiteAreasOnVertex(iCell2, iVertex) + enddo + fVertexAccum = fVertexAccum + baryweight * fieldCells(cellIndex) ! add the contribution from this cell's kite + weightAccum = weightAccum + kiteAreasOnVertex(iCell, iVertex) ! This doesn't match areaTriangle for some weird vertices + enddo + fieldVertices(iVertex) = fVertexAccum / weightAccum ! I assume this should never be 0... + enddo + + end subroutine cells_to_vertices_2dfield + end module li_diagnostic_vars diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index 55865c4300..67491eddfc 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -24,6 +24,7 @@ module li_mask use mpas_grid_types use mpas_configure use mpas_dmpar + use li_setup implicit none @@ -107,7 +108,7 @@ module li_mask ! !----------------------------------------------------------------------- - subroutine li_calculate_mask_init(mesh, state, err) + subroutine li_calculate_mask_init(meshPool, statePool, timeLevel, err) !----------------------------------------------------------------- ! @@ -115,8 +116,11 @@ subroutine li_calculate_mask_init(mesh, state, err) ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in) :: & + timeLevel !< Input: time level for which to init mask !----------------------------------------------------------------- ! @@ -124,8 +128,8 @@ subroutine li_calculate_mask_init(mesh, state, err) ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - state !< Input/Output: state information + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state information !----------------------------------------------------------------- ! @@ -142,12 +146,16 @@ subroutine li_calculate_mask_init(mesh, state, err) !----------------------------------------------------------------- integer, dimension(:), pointer :: cellMask real(KIND=RKIND), dimension(:), pointer :: thickness + logical, pointer :: config_do_restart err = 0 ! Assign pointers and variables - cellMask => state % cellMask % array - thickness => state % thickness % array + call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) + + call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) + if (config_do_restart .eqv. .false.) then ! We only want to set this bit of the mask when a new simulation starts, but not during a restart. ! Initialize cell mask to 0 everywhere before we assign anything to it. @@ -176,7 +184,7 @@ end subroutine li_calculate_mask_init ! !----------------------------------------------------------------------- - subroutine li_calculate_mask(mesh, state, err) + subroutine li_calculate_mask(meshPool, statePool, timeLevel, err) !----------------------------------------------------------------- ! @@ -184,8 +192,11 @@ subroutine li_calculate_mask(mesh, state, err) ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in) :: & + timeLevel !< Input: time level for which to calculate mask !----------------------------------------------------------------- ! @@ -193,8 +204,8 @@ subroutine li_calculate_mask(mesh, state, err) ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - state !< Input/Output: state information + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state information !----------------------------------------------------------------- ! @@ -209,42 +220,42 @@ subroutine li_calculate_mask(mesh, state, err) ! local variables ! !----------------------------------------------------------------- - - - integer :: nCells, nVertices, nEdges - + integer, pointer :: nCells, nVertices, nEdges, vertexDegree real(KIND=RKIND), dimension(:), pointer :: thickness, bedTopography - integer, dimension(:), pointer :: nEdgesOnCell, cellMask, vertexMask, edgeMask - integer, dimension(:,:), pointer :: cellsOnCell, cellsOnVertex, cellsOnEdge + real (kind=RKIND), pointer :: config_ice_density, config_ocean_density, & + config_sea_level, config_dynamic_thickness integer :: i, j, iCell - logical :: isMargin - logical :: aCellOnVertexHasIce, aCellOnVertexHasNoIce, aCellOnVertexHasDynamicIce, aCellOnVertexHasNoDynamicIce, aCellOnVertexIsFloating - logical :: aCellOnEdgeHasIce, aCellOnEdgeHasNoIce, aCellOnEdgeHasDynamicIce, aCellOnEdgeHasNoDynamicIce, aCellOnEdgeIsFloating err = 0 - ! Assign pointers and variables - cellMask => state % cellMask % array - thickness => state % thickness % array - bedTopography => mesh % bedTopography % array - vertexMask => state % vertexMask % array - edgeMask => state % edgeMask % array - nEdgesOnCell => mesh % nEdgesOnCell % array - cellsOnCell => mesh % cellsOnCell % array - cellsOnVertex => mesh % cellsOnVertex % array - cellsOnEdge => mesh % cellsOnEdge % array - - nCells = mesh % nCells - nVertices = mesh % nVertices - nEdges = mesh % nEdges + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) + + call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) + + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) + call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) + call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) ! ==== ! Calculate cellMask values=========================== @@ -317,7 +328,7 @@ subroutine li_calculate_mask(mesh, state, err) aCellOnVertexHasDynamicIce = .false. aCellOnVertexHasNoDynamicIce = .false. aCellOnVertexIsFloating = .false. - do j = 1, mesh % vertexDegree ! vertexDegree is usually 3 (e.g. CVT mesh) but could be something else (e.g. 4 for quad mesh) + do j = 1, vertexDegree ! vertexDegree is usually 3 (e.g. CVT mesh) but could be something else (e.g. 4 for quad mesh) iCell = cellsOnVertex(j,i) aCellOnVertexHasIce = (aCellOnVertexHasIce .or. li_mask_is_ice(cellMask(iCell))) aCellOnVertexHasNoIce = (aCellOnVertexHasNoIce .or. (.not. li_mask_is_ice(cellMask(iCell)))) diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 9670b3442e..87f313b948 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -13,10 +13,7 @@ module mpas_core implicit none private - type (io_output_object), save :: restart_obj - integer :: current_outfile_frames - - type (MPAS_Clock_type) :: clock + type (MPAS_Clock_type), pointer :: clock !-------------------------------------------------------------------- ! @@ -27,7 +24,9 @@ module mpas_core public :: mpas_core_init, & mpas_core_run, & mpas_core_finalize, & - mpas_core_setup_packages + mpas_core_setup_packages, & + mpas_core_setup_clock, & + mpas_core_get_mesh_stream !-------------------------------------------------------------------- ! @@ -35,9 +34,6 @@ module mpas_core ! !-------------------------------------------------------------------- - integer, parameter :: outputAlarmID = 1 - integer, parameter :: restartAlarmID = 2 - !integer, parameter :: statsAlarmID = 3 !*********************************************************************** @@ -59,10 +55,11 @@ module mpas_core ! !----------------------------------------------------------------------- - subroutine mpas_core_init(domain, startTimeStamp) + subroutine mpas_core_init(domain, stream_manager, startTimeStamp) use mpas_configure use mpas_grid_types + use mpas_stream_manager use li_velocity use li_setup !!! use mpas_tracer_advection @@ -82,6 +79,7 @@ subroutine mpas_core_init(domain, startTimeStamp) ! !----------------------------------------------------------------- type (domain_type), intent(inout) :: domain !< Input/output: Domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager !< Input/output: Stream Manager !----------------------------------------------------------------- ! @@ -96,29 +94,52 @@ subroutine mpas_core_init(domain, startTimeStamp) ! !----------------------------------------------------------------- type (block_type), pointer :: block - + type (MPAS_Time_Type) :: startTime integer :: i, err, err_tmp, globalErr + logical, pointer :: config_do_restart err = 0 err_tmp = 0 globalErr = 0 + call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) ! - ! Initialize core + ! Initialize config option settings as needed ! + call li_setup_config_options( domain, err_tmp ) + err = ior(err, err_tmp) - call li_setup_timestep(err_tmp) + ! + ! Set "local" clock to point to the clock contained in the domain type + ! + clock => domain % clock + + ! + ! Set startTimeStamp based on the start time of the simulation clock + ! + startTime = mpas_get_clock_time(clock, MPAS_START_TIME, err_tmp) + call mpas_get_time(startTime, dateTimeString=startTimeStamp) err = ior(err, err_tmp) + if (config_do_restart) then + call mpas_stream_mgr_read(stream_manager, streamID='restart', ierr=err_tmp) + else + call mpas_stream_mgr_read(stream_manager, streamID='input', ierr=err_tmp) + end if + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='restart', ierr=err_tmp) + err = ior(err, err_tmp) + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='input', ierr=err_tmp) + err = ior(err, err_tmp) + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) + err = ior(err, err_tmp) + + ! === ! === Initialize modules === ! === - call simulation_clock_init(domain, li_deltat, startTimeStamp, err_tmp) - err = ior(err, err_tmp) - call mpas_timer_init(domain) call li_velocity_init(domain, err_tmp) @@ -127,17 +148,17 @@ subroutine mpas_core_init(domain, startTimeStamp) !!! call mpas_tracer_advection_init(err_tmp) ! Calling signature may be incorrect here. !!! err = ior(err,err_tmp) + ! === ! === Initialize blocks === ! === block => domain % blocklist do while (associated(block)) - call mpas_init_block(block, block % mesh, startTimeStamp, domain % dminfo) + call landice_init_block(block, startTimeStamp, domain % dminfo) block => block % next end do - current_outfile_frames = 0 ! check for errors and exit call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error @@ -162,15 +183,15 @@ end subroutine mpas_core_init ! !----------------------------------------------------------------------- - subroutine mpas_core_run(domain, output_obj, output_frame) + subroutine mpas_core_run(domain, stream_manager) use mpas_grid_types use mpas_kind_types - use mpas_io_output + use mpas_stream_manager use mpas_timer use li_diagnostic_vars use li_setup -!!! use li_annual_forcing + use mpas_io_streams, only: MPAS_STREAM_LATEST_BEFORE implicit none @@ -186,8 +207,7 @@ subroutine mpas_core_run(domain, output_obj, output_frame) ! !----------------------------------------------------------------- type (domain_type), intent(inout) :: domain !< Input/output: Domain - type (io_output_object), intent(inout) :: output_obj !< Input/output: i/o output object - integer, intent(inout) :: output_frame !< Input/output: output frame number + type (MPAS_streamManager_type), intent(inout) :: stream_manager !< Input/output: Stream Manager !----------------------------------------------------------------- ! @@ -201,18 +221,27 @@ subroutine mpas_core_run(domain, output_obj, output_frame) ! !----------------------------------------------------------------- integer :: itimestep - type (block_type), pointer :: block_ptr + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + logical, pointer :: config_do_restart, config_write_output_on_startup + character(len=StrKIND), pointer :: config_restart_timestamp_name + type (MPAS_Time_Type) :: currTime character(len=StrKIND) :: timeStamp integer :: err, err_tmp, globalErr logical :: solveVelo - ! Note: li_deltat is a module variable in li_setup + type (MPAS_TimeInterval_type) :: timeStepInterval !< time step as an interval + real (kind=RKIND) :: dtSeconds !< time step in seconds err = 0 err_tmp = 0 globalErr = 0 + ! Get Pool stuff that will be needed + call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(liConfigs, 'config_write_output_on_startup', config_write_output_on_startup) + call mpas_pool_get_config(liConfigs, 'config_restart_timestamp_name', config_restart_timestamp_name) call mpas_timer_start("land ice core run") currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) @@ -250,18 +279,11 @@ subroutine mpas_core_run(domain, output_obj, output_frame) ! === ! === Write Initial Output ! === - call write_output_frame(output_obj, output_frame, domain) - -!!! These lines were used previously instead of the one above - but we may need to reassess how we want output to work. -!!! if (config_write_output_on_startup) then -!!! call mpas_timer_start("write output frame") -!!! call write_output_frame(output_obj, output_frame, domain) -!!! call mpas_timer_stop("write output frame") -!!! elseif (config_frames_per_outfile /= 0) then -!!! ! if we are not writing on startup then close the already open file since it will have a confusing time stamp (the time stamp would be the inital time, but the intial time is not present in the file!) -!!! call mpas_output_state_finalize(output_obj, domain % dminfo) -!!! endif - + call mpas_timer_start("write output") + if (config_write_output_on_startup) then + call mpas_stream_mgr_write(stream_manager, 'output', forceWriteNow=.true., ierr=err_tmp) + endif + call mpas_timer_stop("write output") ! === error check and exit call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error @@ -270,6 +292,7 @@ subroutine mpas_core_run(domain, output_obj, output_frame) endif + ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) itimestep = 0 @@ -279,73 +302,82 @@ subroutine mpas_core_run(domain, output_obj, output_frame) do while (.not. mpas_is_clock_stop_time(clock)) itimestep = itimestep + 1 + + ! Get the interval at this point in time - currently this does not change during the simulation, but re-calculating it explicitly for generality + timeStepInterval = mpas_get_clock_timestep(clock, ierr=err_tmp) + err = ior(err,err_tmp) + ! Convert the clock's time interval into a dt in seconds to be used by the time stepper, using the currTime as the start time for this interval. + ! (We want to do this conversion before advancing the clock because the dt in seconds may change + ! as the base time changes, and we want the old time as the base time. + ! For example, the number of seconds in a year will be longer in a leap year.) + call mpas_get_timeInterval(timeStepInterval, StartTimeIn=currTime, dt=dtSeconds, ierr=err_tmp) + err = ior(err,err_tmp) + call mpas_advance_clock(clock) currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) - call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) err = ior(err, err_tmp) write(0,*) 'Doing timestep ', trim(timeStamp) write(6,*) 'Doing timestep ', trim(timeStamp) -!!! These lines were used previously to assign annual forcing fields. We may want to reassess how to do that. -!!! call mpas_timer_start("assign forcing fields") -!!! block_ptr => domain % blocklist -!!! do while(associated(block_ptr)) -!!! call li_assign_annual_forcing(currTime, block_ptr % mesh, ierr) -!!! block_ptr => block_ptr % next -!!! end do -!!! call mpas_timer_stop("assign forcing fields") + !write(6,*) ' dt (s) = ', dtSeconds ! === ! === Perform Timestep ! === call mpas_timer_start("time integration") - call mpas_timestep(domain, itimestep, li_deltat, timeStamp, err_tmp) + + call landice_timestep(domain, itimestep, dtSeconds, timeStamp, err_tmp) err = ior(err,err_tmp) ! Move time level 2 fields back into time level 1 for next time step - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_shift_time_levels_state(block_ptr % state) - block_ptr => block_ptr % next + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_shift_time_levels(statePool) + block => block % next end do call mpas_timer_stop("time integration") - !TODO: mpas_get_clock_ringing_alarms is probably faster than multiple mpas_is_alarm_ringing... - ! === - ! === Write Output, if needed + ! === Read time-varying inputs, if present (i.e., forcing) ! === - if (mpas_is_alarm_ringing(clock, outputAlarmID, ierr=err_tmp)) then - call mpas_timer_start("write output") - call mpas_reset_clock_alarm(clock, outputAlarmID, ierr=err_tmp) - ! output_frame will always be > 1 here unless it was reset after the maximum number of frames per outfile was reached - ! MJH: See old code for adjustments made here to deal with some obscure, specific use-cases - 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)) - end if - call write_output_frame(output_obj, output_frame, domain) - call mpas_timer_stop("write output") - end if + ! This should happen at the end of the time step so that if we write out + ! the forcing it is at the correct time level. + ! For an explicit time-stepping method, we want the forcing to be at the + ! *old* time when it is applied during time integration. Reading it here + ! will allow that. + ! Finally, set whence to latest_before so we have piecewise-constant forcing. + ! Could add, e.g., linear interpolation later. + call mpas_stream_mgr_read(stream_manager, whence=MPAS_STREAM_LATEST_BEFORE, ierr=err_tmp) + err = ior(err, err_tmp) + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_INPUT, ierr=err_tmp) err = ior(err, err_tmp) + ! === - ! === Write Restart, if needed + ! === Write Output and/or Restart, if needed ! === - if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=err_tmp)) then - call mpas_timer_start("write restart") - call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=err_tmp) - - ! Write one restart time per file - call mpas_output_state_init(restart_obj, domain, "RESTART", trim(timeStamp)) - call mpas_output_state_for_domain(restart_obj, domain, 1) - call mpas_output_state_finalize(restart_obj, domain % dminfo) - call mpas_timer_stop("write restart") + call mpas_timer_start("write output") + ! Update the restart_timestamp file with the new time, if needed. + if ( mpas_stream_mgr_ringing_alarms(stream_manager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) ) then + open(22, file=config_restart_timestamp_name, form='formatted', status='replace') + write(22, *) timeStamp + close(22) end if err = ior(err, err_tmp) + ! These calls will handle ALL output streams that need writing. + ! [Could add them individually, as the ocean does, if some other actions are needed when a + ! specific alarm is ringing (e.g., global stats calculated only when output stream gets written)] + call mpas_stream_mgr_write(stream_manager, ierr=err_tmp) + err = ior(err, err_tmp) + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) + err = ior(err, err_tmp) + call mpas_timer_stop("write output") + ! === error check and exit call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error @@ -356,8 +388,6 @@ subroutine mpas_core_run(domain, output_obj, output_frame) end do call mpas_timer_stop("land ice core run") - - !-------------------------------------------------------------------- end subroutine mpas_core_run @@ -374,9 +404,10 @@ end subroutine mpas_core_run !> This routine finalizes the land ice core. ! !----------------------------------------------------------------------- - subroutine mpas_core_finalize(domain) + subroutine mpas_core_finalize(domain, stream_manager) use mpas_grid_types + use mpas_stream_manager use li_velocity, only: li_velocity_finalize implicit none @@ -393,6 +424,7 @@ subroutine mpas_core_finalize(domain) ! !----------------------------------------------------------------- type (domain_type), intent(inout) :: domain !< Input/output: Domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager !< Input/output: Stream Manager !----------------------------------------------------------------- ! @@ -427,6 +459,104 @@ subroutine mpas_core_finalize(domain) end subroutine mpas_core_finalize + +!*********************************************************************** +! +! routine mpas_core_setup_packages +! +!> \brief Pacakge setup routine +!> \author Doug Jacobsen +!> \date September 2011 +!> \details +!> This routine is intended to correctly configure the packages for this MPAS +!> core. It can use any Fortran logic to properly configure packages, and it +!> can also make use of any namelist options. All variables in the model are +!> *not* allocated until after this routine is called. +! +!----------------------------------------------------------------------- + subroutine mpas_core_setup_packages(configPool, packagePool, ierr) + + implicit none + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + integer, intent(out) :: ierr + + ierr = 0 + + end subroutine mpas_core_setup_packages + + + +!*********************************************************************** +! +! routine mpas_core_setup_clock +! +!> \brief Pacakge setup routine +!> \author Michael Duda +!> \date 6 August 2014 +!> \details +!> The purpose of this routine is to allow the core to set up a simulation +!> clock that will be used by the I/O subsystem for timing reads and writes +!> of I/O streams. +!> This routine is called from the superstructure after the framework +!> has been initialized but before any fields have been allocated and +!> initial fields have been read from input files. However, all namelist +!> options are available. +! +!----------------------------------------------------------------------- + subroutine mpas_core_setup_clock(core_clock, configs, ierr) + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + call simulation_clock_init(core_clock, configs, ierr) + + end subroutine mpas_core_setup_clock + + +!*********************************************************************** +! +! routine mpas_core_get_mesh_stream +! +!> \brief Returns the name of the stream containing mesh information +!> \author Michael Duda +!> \date 8 August 2014 +!> \details +!> This routine returns the name of the I/O stream containing dimensions, +!> attributes, and mesh fields needed by the framework bootstrapping +!> routine. At the time this routine is called, only namelist options +!> are available. +! +!----------------------------------------------------------------------- +subroutine mpas_core_get_mesh_stream(configs, stream, ierr) + + implicit none + + type (mpas_pool_type), intent(in) :: configs + character(len=*), intent(out) :: stream + integer, intent(out) :: ierr + + logical, pointer :: config_do_restart + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) + + if (.not. associated(config_do_restart)) then + ierr = 1 + else if (config_do_restart) then + write(stream,'(a)') 'restart' + else + write(stream,'(a)') 'input' + end if + + end subroutine mpas_core_get_mesh_stream + + + !*********************************************************************** !*********************************************************************** ! Private subroutines: @@ -437,7 +567,7 @@ end subroutine mpas_core_finalize !*********************************************************************** ! -! routine mpas_init_block +! routine landice_init_block ! !> \brief Initializes blocks for the land ice core !> \author Matt Hoffman @@ -446,8 +576,8 @@ end subroutine mpas_core_finalize !> This routine initializes blocks for the land ice core. ! !----------------------------------------------------------------------- - subroutine mpas_init_block(block, mesh, startTimeStamp, dminfo) - + subroutine landice_init_block(block, startTimeStamp, dminfo) + use mpas_grid_types use mpas_rbf_interpolation use mpas_vector_reconstruction @@ -462,7 +592,7 @@ subroutine mpas_init_block(block, mesh, startTimeStamp, dminfo) ! input variables ! !----------------------------------------------------------------- - type (dm_info), intent(in) :: dminfo !< Input: Domain info + type (dm_info), intent(in) :: dminfo !< Input: Domain info character(len=*), intent(in) :: startTimeStamp !< Input: time stamp at start !----------------------------------------------------------------- @@ -470,8 +600,7 @@ subroutine mpas_init_block(block, mesh, startTimeStamp, dminfo) ! input/output variables ! !----------------------------------------------------------------- - type (block_type), intent(inout) :: block !< Input/output: Block object - type (mesh_type), intent(inout) :: mesh !< Input/output: Mesh object + type (block_type), intent(inout) :: block !< Input/output: Block object !----------------------------------------------------------------- ! @@ -484,40 +613,29 @@ subroutine mpas_init_block(block, mesh, startTimeStamp, dminfo) ! local variables ! !----------------------------------------------------------------- + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool + character (len=StrKIND), pointer :: xtime type (MPAS_Time_Type) :: currTime integer :: err, err_tmp - - type (state_type), pointer :: state - integer :: iCell, iLevel, i err = 0 err_tmp = 0 - state => block % state % time_levs(1) % state ! initial state - - ! Make sure all time levels have a copy of the initial state - do i=2,nTimeLevs - call mpas_copy_state(block % state % time_levs(i) % state, state) - end do - - ! Assign initial time stamp - state % xtime % scalar = startTimeStamp + ! Get pool stuff + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) ! === ! === Call init routines === ! === - call li_setup_vertical_grid(mesh, err_tmp) + call li_setup_vertical_grid(meshPool, err_tmp) err = ior(err, err_tmp) - call li_setup_sign_and_index_fields(mesh) + call li_setup_sign_and_index_fields(meshPool) -! This was needed for annual forcing, which may or not be implemented in the same way. -!!! currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) -!!! err = ior(err, err_tmp) -!!! call li_assign_annual_forcing(currTime, mesh, err_tmp) -!!! err = ior(err, err_tmp) ! This was needed to init FCT once. !!! ! Init for FCT tracer advection @@ -534,27 +652,33 @@ subroutine mpas_init_block(block, mesh, startTimeStamp, dminfo) call mpas_timer_stop("initialize velocity") ! Init for reconstruction of velocity - call mpas_rbf_interp_initialize(mesh) - call mpas_init_reconstruct(mesh) + call mpas_rbf_interp_initialize(meshPool) + call mpas_init_reconstruct(meshPool) + + ! Assign initial time stamp + call mpas_pool_get_array(statePool, 'xtime', xtime, timeLevel=1) + xtime = startTimeStamp ! Mask init identifies initial ice extent - call li_calculate_mask_init(mesh, state, err) + call li_calculate_mask_init(meshPool, statePool, timeLevel=1, err=err_tmp) err = ior(err, err_tmp) + ! Make sure all time levels have a copy of the initial state + call mpas_pool_initialize_time_levels(statePool) ! === error check if (err > 0) then - write (0,*) "An error has occurred in mpas_init_block." + write (0,*) "An error has occurred in init_block." endif !-------------------------------------------------------------------- - end subroutine mpas_init_block + end subroutine landice_init_block !*********************************************************************** ! -! routine mpas_timestep +! routine landice_timestep ! !> \brief Performs a time step !> \author Matt Hoffman @@ -563,7 +687,7 @@ end subroutine mpas_init_block !> This routine performs a time step for the land ice core. ! !----------------------------------------------------------------------- - subroutine mpas_timestep(domain, itimestep, dt, timeStamp, err) + subroutine landice_timestep(domain, itimestep, dt, timeStamp, err) use mpas_grid_types use li_time_integration @@ -578,7 +702,7 @@ subroutine mpas_timestep(domain, itimestep, dt, timeStamp, err) ! !----------------------------------------------------------------- integer, intent(in) :: itimestep !< Input: time step number - real (kind=RKIND), intent(in) :: dt !< Input: time step + real (kind=RKIND), intent(in) :: dt !< Input: time step, in seconds character(len=*), intent(in) :: timeStamp !< Input: time stamp of current time step !----------------------------------------------------------------- @@ -650,7 +774,7 @@ subroutine mpas_timestep(domain, itimestep, dt, timeStamp, err) endif - end subroutine mpas_timestep + end subroutine landice_timestep @@ -666,7 +790,7 @@ end subroutine mpas_timestep ! !----------------------------------------------------------------------- - subroutine simulation_clock_init(domain, dt, startTimeStamp, ierr) + subroutine simulation_clock_init(core_clock, configs, ierr) implicit none @@ -675,21 +799,21 @@ subroutine simulation_clock_init(domain, dt, startTimeStamp, ierr) ! input variables ! !----------------------------------------------------------------- - real (kind=RKIND), intent(in) :: dt !< Input: time step + !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain !< Input/output: Domain + type (MPAS_Clock_type), intent(inout) :: core_clock !< Input/output: core_clock + type (mpas_pool_type), intent(inout) :: configs !< Input/output: configs !----------------------------------------------------------------- ! ! output variables ! !----------------------------------------------------------------- - character(len=*), intent(out) :: startTimeStamp !< Output: time stamp at start integer, intent(out) :: ierr !< Output: error flag !----------------------------------------------------------------- @@ -699,21 +823,46 @@ subroutine simulation_clock_init(domain, dt, startTimeStamp, ierr) !----------------------------------------------------------------- type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep + character (len=StrKIND), pointer :: config_start_time, config_run_duration, config_stop_time, config_output_interval, config_restart_interval ! MPAS standard configs + character (len=StrKIND), pointer :: config_dt ! MPAS LI-specific config option + character (len=StrKIND), pointer :: config_restart_timestamp_name + character (len=StrKIND) :: restartTimeStamp !< string to be read from file integer :: err_tmp ierr = 0 err_tmp = 0 - call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=err_tmp) - ierr = ior(ierr,err_tmp) - call mpas_set_timeInterval(timeStep, dt=dt, ierr=err_tmp) + call mpas_pool_get_config(configs, 'config_dt', config_dt) + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_run_duration', config_run_duration) + call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) + call mpas_pool_get_config(configs, 'config_output_interval', config_output_interval) + call mpas_pool_get_config(configs, 'config_restart_interval', config_restart_interval) + call mpas_pool_get_config(configs, 'config_restart_timestamp_name', config_restart_timestamp_name) + + + ! Set time to the user-specified start time OR use a restart time from file + if ( trim(config_start_time) == "file" ) then + open(22, file=config_restart_timestamp_name, form='formatted', status='old') + read(22,*) restartTimeStamp + close(22) + call mpas_set_time(curr_time=startTime, dateTimeString=restartTimeStamp, ierr=err_tmp) + ierr = ior(ierr,err_tmp) + else + call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=err_tmp) + ierr = ior(ierr,err_tmp) + end if + + ! Set interval to the user-specified time interval string + call mpas_set_timeInterval(timeStep, timeString=config_dt, ierr=err_tmp) ierr = ior(ierr,err_tmp) + if (trim(config_run_duration) /= "none") then call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=err_tmp) ierr = ior(ierr,err_tmp) - call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=err_tmp) ierr = ior(ierr,err_tmp) if (trim(config_stop_time) /= "none") then @@ -726,40 +875,13 @@ subroutine simulation_clock_init(domain, dt, startTimeStamp, ierr) else if (trim(config_stop_time) /= "none") then call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) ierr = ior(ierr,err_tmp) - call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=err_tmp) ierr = ior(ierr,err_tmp) else write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' - call mpas_dmpar_abort(domain % dminfo) - end if - - ! set output alarm - call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=err_tmp) - ierr = ior(ierr,err_tmp) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=err_tmp) - ierr = ior(ierr,err_tmp) - - ! set restart alarm, if necessary - if (trim(config_restart_interval) /= "none") then - call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=err_tmp) - ierr = ior(ierr,err_tmp) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=err_tmp) - ierr = ior(ierr,err_tmp) + ierr = 1 end if - !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=err_tmp) - ! alarmStartTime = startTime + alarmTimeStep - ! call mpas_add_clock_alarm(clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=err_tmp) - !end if - - call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=err_tmp) - ierr = ior(ierr,err_tmp) ! === error check if (ierr > 0) then @@ -768,122 +890,7 @@ subroutine simulation_clock_init(domain, dt, startTimeStamp, ierr) !-------------------------------------------------------------------- end subroutine simulation_clock_init - - -!*********************************************************************** -! -! routine write_output_frame -! -!> \brief Writes an output frame -!> \author ?? -!> \date ?? -!> \details -!> This routine writes an output frame. -! -!----------------------------------------------------------------------- - subroutine write_output_frame(output_obj, output_frame, domain) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Compute diagnostic fields for a domain and write model state to output file - ! - ! Input/Output: domain - contains model state; diagnostic field are computed - ! before returning - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_grid_types - use mpas_io_output - - implicit none - - type (io_output_object), intent(inout) :: output_obj - integer, intent(inout) :: output_frame - type (domain_type), intent(inout) :: domain - - integer :: i, j, k - integer :: eoe - type (block_type), pointer :: block_ptr - - block_ptr => domain % blocklist - do while (associated(block_ptr)) - call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh) - block_ptr => block_ptr % next - end do - - call mpas_output_state_for_domain(output_obj, domain, output_frame) - output_frame = output_frame + 1 - - ! reset frame if the maximum number of frames per outfile has been reached - if (config_frames_per_outfile > 0) then - current_outfile_frames = current_outfile_frames + 1 - if(current_outfile_frames >= config_frames_per_outfile) then -! MJH: My old version did things a bit differently here. - current_outfile_frames = 0 - output_frame = 1 - end if - end if - - end subroutine write_output_frame - - - -!*********************************************************************** -! -! routine compute_output_diagnostics -! -!> \brief Computes diagnostic fields only needed for output -!> \author ?? -!> \date ?? -!> \details -!> This routine is a placeholder for the calculation of any -!> fields that are only needed for diagnostic output. -! -!----------------------------------------------------------------------- - subroutine compute_output_diagnostics(state, mesh) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Compute diagnostic fields for a domain - ! - ! Input: state - contains model prognostic fields - ! mesh - contains mesh metadata - ! - ! Output: state - upon returning, diagnostic fields will have be computed - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_grid_types - - implicit none - - type (state_type), intent(inout) :: state - type (mesh_type), intent(in) :: mesh - - integer :: i, eoe - integer :: iEdge, k - - end subroutine compute_output_diagnostics - -!*********************************************************************** -! -! routine mpas_core_setup_packages -! -!> \brief Pacakge setup routine -!> \author Doug Jacobsen -!> \date September 2011 -!> \details -!> This routine is intended to correctly configure the packages for this MPAS -!> core. It can use any Fortran logic to properly configure packages, and it -!> can also make use of any namelist options. All variables in the model are -!> *not* allocated until after this routine is called. -! -!----------------------------------------------------------------------- - subroutine mpas_core_setup_packages(ierr)!{{{ - - use mpas_packages - - implicit none - - integer, intent(out) :: ierr - - ierr = 0 - end subroutine mpas_core_setup_packages!}}} end module mpas_core diff --git a/src/core_landice/mpas_li_setup.F b/src/core_landice/mpas_li_setup.F index d07744974f..cd8bd85609 100644 --- a/src/core_landice/mpas_li_setup.F +++ b/src/core_landice/mpas_li_setup.F @@ -35,27 +35,18 @@ module li_setup ! !-------------------------------------------------------------------- - real (kind=RKIND) :: li_deltat !< Public parameter: Time step used by model - public :: li_deltat - ! Note: li_deltat is a public module level variable so it can be used by other - ! modules. This was necessitated because deltat needs to be set during mpas_core_init - ! but used in mpas_core_run and there is currently no way to pass it between those - ! subroutines in the existing driver. Note: if we create an adaptive time-stepper - ! then we will need to write an accessor subroutine to modify deltat as needed. - ! I first considered just making deltat a module level variable in li_mpas_core - ! but that seemed kind of messy and would not work if deltat becomes adaptive. - ! I also considered making a new moduled called li_parameters where this and - ! any other landice-specific constants could live as public variables, but for - ! now I am keeping it here. + type (mpas_pool_type), pointer :: liConfigs !< Public parameter: pool of config options + + public :: liConfigs !-------------------------------------------------------------------- ! ! Public member functions ! !-------------------------------------------------------------------- - public :: li_setup_vertical_grid, & - li_setup_sign_and_index_fields, & - li_setup_timestep + public :: li_setup_config_options, & + li_setup_vertical_grid, & + li_setup_sign_and_index_fields !-------------------------------------------------------------------- ! @@ -69,6 +60,61 @@ module li_setup contains + +!*********************************************************************** +! +! routine li_setup_config_options +! +!> \brief Makes any setup changes needed based on chosen config options +!> \author Matt Hoffman +!> \date 16 April 2014 +!> \details +!> This routine makes any adjustments as needed based on which +!> config options were chosen. +! +!----------------------------------------------------------------------- + + subroutine li_setup_config_options( domain, err ) + + use mpas_timekeeping + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer, pointer :: config_year_digits + + err = 0 + + ! Make config pool publicly available in this module + liConfigs => domain % configs + + ! --- + ! Config-specific setup occurs below + ! --- + + ! Adjust number of digits representing the year + call mpas_pool_get_config(liConfigs, 'config_year_digits', config_year_digits) + call mpas_timekeeping_set_year_width(config_year_digits) + + !-------------------------------------------------------------------- + end subroutine li_setup_config_options + + + !*********************************************************************** ! ! routine li_setup_vertical_grid @@ -81,7 +127,7 @@ module li_setup ! !----------------------------------------------------------------------- - subroutine li_setup_vertical_grid(mesh, err) + subroutine li_setup_vertical_grid(meshPool, err) !----------------------------------------------------------------- ! @@ -95,7 +141,7 @@ subroutine li_setup_vertical_grid(mesh, err) ! input/output variables ! !----------------------------------------------------------------- - type (mesh_type), intent(inout) :: mesh !< Input/Output: mesh object + type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh object !----------------------------------------------------------------- ! @@ -110,14 +156,19 @@ subroutine li_setup_vertical_grid(mesh, err) ! local variables ! !----------------------------------------------------------------- - - integer :: nVertLevels, k - real (kind=RKIND) :: fractionTotal + ! Pool pointers + integer, pointer :: nVertLevels ! Dimensions real (kind=RKIND), dimension(:), pointer :: layerThicknessFractions, layerCenterSigma, layerInterfaceSigma + ! Truly locals + integer :: k + real (kind=RKIND) :: fractionTotal - nVertLevels = mesh % nVertLevels + ! Get pool stuff + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) ! layerThicknessFractions is provided by input - layerThicknessFractions => mesh % layerThicknessFractions % array + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) ! Check that layerThicknessFractions are valid ! TODO - switch to having the user input the sigma levels instead??? @@ -132,12 +183,8 @@ subroutine li_setup_vertical_grid(mesh, err) layerThicknessFractions(1) = layerThicknessFractions(1) - (fractionTotal - 1.0_RKIND) endif - ! layerCenterSigma is the fractional vertical position (0-1) of each layer center, with 0.0 at the ice surface and 1.0 at the ice bed - layerCenterSigma => mesh % layerCenterSigma % array ! layerInterfaceSigma is the fractional vertical position (0-1) of each layer interface, with 0.0 at the ice surface and 1.0 at the ice bed. Interface 1 is the surface, interface 2 is between layers 1 and 2, etc., and interface nVertLevels+1 is the bed. - layerInterfaceSigma => mesh % layerInterfaceSigma % array - layerCenterSigma(1) = 0.5_RKIND * layerThicknessFractions(1) layerInterfaceSigma(1) = 0.0_RKIND do k = 2, nVertLevels @@ -146,7 +193,7 @@ subroutine li_setup_vertical_grid(mesh, err) layerInterfaceSigma(k) = layerInterfaceSigma(k-1) + layerThicknessFractions(k-1) end do layerInterfaceSigma(nVertLevels+1) = 1.0_RKIND - + !-------------------------------------------------------------------- end subroutine li_setup_vertical_grid @@ -163,7 +210,7 @@ end subroutine li_setup_vertical_grid !> This routine determines the sign for various mesh items. ! !----------------------------------------------------------------------- - subroutine li_setup_sign_and_index_fields(mesh)!{{{ + subroutine li_setup_sign_and_index_fields(meshPool) !----------------------------------------------------------------- ! @@ -176,7 +223,7 @@ subroutine li_setup_sign_and_index_fields(mesh)!{{{ ! input/output variables ! !----------------------------------------------------------------- - type (mesh_type), intent(inout) :: mesh !< Input/Output: mesh object + type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh object !----------------------------------------------------------------- ! @@ -189,34 +236,29 @@ subroutine li_setup_sign_and_index_fields(mesh)!{{{ ! local variables ! !----------------------------------------------------------------- - integer, dimension(:), pointer :: nEdgesOnCell - integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge !, edgesOnVertex, cellsOnVertex, verticesOnCell, verticesOnEdge - integer, dimension(:,:), pointer :: edgeSignOnCell !, edgeSignOnVertex, kiteIndexOnCell - - integer :: nCells !, nVertices, vertexDegree + ! Pool pointers + integer, pointer :: nCells !, nVertices, vertexDegree + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge !, edgesOnVertex, cellsOnVertex, verticesOnCell, verticesOnEdge + integer, dimension(:,:), pointer :: edgeSignOnCell !, edgeSignOnVertex, kiteIndexOnCell + ! Truly locals integer :: iCell, iEdge, iVertex, i, j, k - nCells = mesh % nCells - !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 + ! Get pool stuff + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + ! layerThicknessFractions is provided by input + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) edgeSignOnCell = 0.0_RKIND !edgeSignOnVertex = 0.0_RKIND !kiteIndexOnCell = 0.0_RKIND + ! If needed, edgeSignOnVertex and kiteIndexOnCell can also be setup here. do iCell = 1, nCells - do i = 1, nEdgesOnCell(iCell) + do i = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(i, iCell) !iVertex = verticesOnCell(i, iCell) @@ -249,70 +291,7 @@ subroutine li_setup_sign_and_index_fields(mesh)!{{{ !end do !-------------------------------------------------------------------- - end subroutine li_setup_sign_and_index_fields!}}} - - - -!*********************************************************************** -! -! routine li_setup_timestep -! -!> \brief Initializes time step -!> \author Matt Hoffman -!> \date 24 September 2013 -!> \details -!> This routine initializes the time step based on whether -!> config_dt or config_dt_years has been set in the namelist. -! -!----------------------------------------------------------------------- - - subroutine li_setup_timestep( err ) - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - err = 0 - - ! If dt in years is supplied, convert it to seconds and use it. Otherwise use dt in seconds - ! li_deltat is a module variable - if (config_dt_years == 0.0_RKIND) then - li_deltat = config_dt_seconds - else - li_deltat = config_dt_years * (365.0 * 24.0 * 3600.0) - ! TODO Should seconds in a year be dependent on calendar used? - ! TODO Should seconds in a year be a parameter/module variable somewhere - endif - - if (li_deltat < 0.0_RKIND) then - err = 1 - write(0,*) 'Error: negative time step was specified.' - endif - - !-------------------------------------------------------------------- - end subroutine li_setup_timestep + end subroutine li_setup_sign_and_index_fields diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index 441c8e28c0..efb1934b44 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -25,6 +25,7 @@ module li_sia use mpas_configure use mpas_dmpar use li_mask + use li_setup implicit none private @@ -172,7 +173,7 @@ end subroutine li_sia_block_init !> on an edge using the average of the two neighboring cells (2nd order). ! !----------------------------------------------------------------------- - subroutine li_sia_solve(mesh, state, err) + subroutine li_sia_solve(meshPool, statePool, timeLevel, err) use mpas_constants, only: gravity !----------------------------------------------------------------- @@ -181,8 +182,11 @@ subroutine li_sia_solve(mesh, state, err) ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in) :: & + timeLevel !< Input: time level from which to calculate velocity !----------------------------------------------------------------- ! @@ -190,8 +194,8 @@ subroutine li_sia_solve(mesh, state, err) ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - state !< Input: state information + type (mpas_pool_type), intent(inout) :: & + statePool !< Input: state information !----------------------------------------------------------------- ! @@ -207,40 +211,48 @@ subroutine li_sia_solve(mesh, state, err) ! !----------------------------------------------------------------- - real (kind=RKIND), dimension(:), pointer :: thickness, layerCenterSigma, dcEdge + real (kind=RKIND), dimension(:), pointer :: thickness, layerCenterSigma, dcEdge, dvEdge, upperSurface, upperSurfaceVertex real (kind=RKIND), dimension(:,:), pointer :: normalVelocity - integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge integer, dimension(:), pointer :: edgeMask - integer :: nVertLevels, nEdges, iLevel, iEdge, cell1, cell2 + integer, pointer :: nVertLevels, nEdges, nVertices, vertexDegree + integer :: iLevel, iEdge, iCell, iVertex, cell1, cell2, cellIndex real (kind=RKIND) :: basalVelocity, slopeOnEdge, & - layerCenterHeightOnEdge, thicknessEdge - real (kind=RKIND) :: rhoi ! ice density - real (kind=RKIND) :: ratefactor ! flow law parameter, A - real (kind=RKIND) :: n ! flow law exponent, n + normalSlopeOnEdge, tangentSlopeOnEdge, & + layerCenterHeightOnEdge, thicknessEdge, hVertexAccum + real (kind=RKIND), pointer :: rhoi ! ice density + real (kind=RKIND), pointer :: ratefactor ! flow law parameter, A + real (kind=RKIND), pointer :: n ! flow law exponent, n err = 0 ! Set needed variables and pointers - nEdges = mesh % nEdges - nVertLevels = mesh % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) - dcEdge => mesh % dcEdge % array - cellsOnEdge => mesh % cellsOnEdge % array - layerCenterSigma => mesh % layerCenterSigma % array + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) - normalVelocity => state % normalVelocity % array - thickness => state % thickness % array - edgeMask => state % edgeMask % array ! Get parameters specified in the namelist - rhoi = config_ice_density - n = config_flowLawExponent + call mpas_pool_get_config(liConfigs, 'config_ice_density', rhoi) + call mpas_pool_get_config(liConfigs, 'config_flowLawExponent', n) + call mpas_pool_get_config(liConfigs, 'config_default_flowParamA', ratefactor) ! units of s^{-1} Pa^{-n} ! Calculate ratefactor (A) at edge - TODO This should be calculated external to this subroutine and as a function of temperature - ratefactor = config_default_flowParamA ! units of s^{-1} Pa^{-n} basalVelocity = 0.0_RKIND ! Assume no sliding - ! Loop over edges do iEdge = 1, nEdges ! Only calculate velocity for edges that are part of the dynamic ice sheet.(thick ice) @@ -250,7 +262,9 @@ subroutine li_sia_solve(mesh, state, err) cell2 = cellsOnEdge(2,iEdge) ! Calculate slope at edge ! This could/should be calculated externally to this subroutine - slopeOnEdge = (thickness(cell1) - thickness(cell2) ) / dcEdge(iEdge) + normalSlopeOnEdge = (upperSurface(cell1) - upperSurface(cell2) ) / dcEdge(iEdge) + tangentSlopeOnEdge = ( upperSurfaceVertex(verticesOnEdge(1,iEdge)) - upperSurfaceVertex(verticesOnEdge(2,iEdge)) ) / dvEdge(iEdge) + slopeOnEdge = (normalSlopeOnEdge**2 + tangentSlopeOnEdge**2)**0.5 ! Calculate thickness on edge - 2nd order thicknessEdge = (thickness(cell1) + thickness(cell2) ) * 0.5_RKIND ! Loop over layers @@ -259,13 +273,13 @@ subroutine li_sia_solve(mesh, state, err) layerCenterHeightOnEdge = thicknessEdge * (1.0_RKIND - layerCenterSigma(iLevel) ) ! Calculate SIA velocity normalVelocity(iLevel,iEdge) = basalVelocity + & - 0.5_RKIND * ratefactor * (rhoi * gravity)**n * slopeOnEdge**n * & + 0.5_RKIND * ratefactor * (rhoi * gravity)**n * slopeOnEdge**(n-1) * normalSlopeOnEdge * & (thicknessEdge**(n+1) - (thicknessEdge - layerCenterHeightOnEdge)**(n+1)) end do ! Levels + else + normalVelocity(:,iEdge) = 0.0_RKIND endif end do ! edges - - ! === error check if (err > 0) then diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index 1d95838785..1c9a938beb 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -26,6 +26,7 @@ module li_tendency use mpas_configure use mpas_constants use mpas_dmpar + use li_setup !!! use li_mask !!! use mpas_tracer_advection @@ -72,7 +73,7 @@ module li_tendency ! !----------------------------------------------------------------------- - subroutine li_tendency_thickness(mesh, state, layerThickness_tend, dt, dminfo, allowableDt, err) + subroutine li_tendency_thickness(meshPool, statePool, layerThickness_tend, dt, dminfo, allowableDt, err) !----------------------------------------------------------------- ! @@ -80,8 +81,8 @@ subroutine li_tendency_thickness(mesh, state, layerThickness_tend, dt, dminfo, a ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), intent(in) :: & dt !< Input: dt @@ -95,8 +96,8 @@ subroutine li_tendency_thickness(mesh, state, layerThickness_tend, dt, dminfo, a ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - state !< Input: state to use to calculate tendency (old time level) + type (mpas_pool_type), intent(inout) :: & + statePool !< Input: state to use to calculate tendency (old time level) ! Note: state needs to be inout (rather than just in) so that adjust_marine_boundary_fluxes can modify it. real (kind=RKIND), dimension(:,:), pointer, intent(inout) :: & @@ -120,38 +121,46 @@ subroutine li_tendency_thickness(mesh, state, layerThickness_tend, dt, dminfo, a ! local variables ! !----------------------------------------------------------------- - integer nVertLevels + integer, pointer :: nVertLevels real (kind=RKIND), dimension(:), pointer :: sfcMassBal + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, layerThicknessEdge !!! real (kind=RKIND), dimension(:), pointer :: iceArea, areaCell, marineBasalMassBal - integer, dimension(:), pointer :: cellMask + integer, dimension(:), pointer :: cellMask, edgeMask + character (len=StrKIND), pointer :: config_thickness_advection + real (kind=RKIND), pointer :: config_ice_density integer :: err_tmp err = 0 err_tmp = 0 - nVertLevels = mesh % nVertLevels - sfcMassBal => mesh % sfcMassBal % array + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'sfcMassBal', sfcMassBal) + ! Assuming tendency will always be calculated using time level 1! + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=1) + call mpas_pool_get_array(statePool, 'layerThicknessEdge', layerThicknessEdge, timeLevel=1) + call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=1) + call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=1) !!! marineBasalMassBal => mesh % marineBasalMassBal % array !!! iceArea => state % iceArea % array !!! areaCell => mesh % areaCell % array - cellMask => state % cellMask % array - + call mpas_pool_get_config(liConfigs, 'config_thickness_advection', config_thickness_advection) + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) ! 0 tendency - layerThickness_tend = 0.0_RKIND + layerThickness_tend = 0.0_RKIND !!! iceArea_tend = 0.0_RKIND - select case (config_thickness_advection) - case ('fo') !=================================================== + select case (trim(config_thickness_advection)) + case ('fo') !=================================================== !print *,'Using FO Upwind for thickness advection' !!! ! Alternate call to calculate thickness tendency for entire ice column (deprecated) !!! !call li_tend_h_fo_upwind(mesh, state % normalVelocity % array, & !!! ! state % layerThickness % array, state % thickness % array, thickness_tend, dt, err) - call tend_layerthickness_fo_upwind(mesh, state % normalVelocity % array, & - state % layerThicknessEdge % array, state % edgeMask % array, layerThickness_tend, dt, allowableDt, err_tmp) + call tend_layerthickness_fo_upwind(meshPool, normalVelocity, & + layerThicknessEdge, edgeMask, layerThickness_tend, dt, allowableDt, err_tmp) !!! Experimental implementation of using FCT for thickness tendency calculation @@ -179,20 +188,20 @@ subroutine li_tendency_thickness(mesh, state, layerThickness_tend, dt, dminfo, a ! assign to the thickness tend i actually use ! layerThickness_tend = block % tend % sup_thickness % array(1,:,:) - case ('none') !=================================================== + case ('none') !=================================================== ! Do nothing - case default !=================================================== + case default !=================================================== write(0,*) trim(config_thickness_advection), ' is not a valid thickness advection option.' err_tmp = 1 - end select !=================================================== - err = ior(err,err_tmp) + end select !=================================================== + err = ior(err,err_tmp) - ! Add the MB to the tendencies - select case (config_thickness_advection) - case ('None') !=================================================== + ! Add the MB to the tendencies + select case (trim(config_thickness_advection)) + case ('None') !=================================================== ! Do nothing - don't add the MB - case default + case default ! Commenting BMB out for now. !!! ! Make some potential adjustments to BMB before applying them. !!! ! It's ok to overwrite the values with 0's here, because each time step @@ -223,12 +232,12 @@ subroutine li_tendency_thickness(mesh, state, layerThickness_tend, dt, dminfo, a !!! + mesh % marineBasalMassBal % array ! (tendency in meters per year) !!! ! TODO Add in grounded ice basal mass balance once temperature diffusion is calculated !!! ! TODO THIS MIGHT RESULT IN NEGATIVE LAYER THICKNESS! - end select + end select - ! === error check - if (err > 0) then + ! === error check + if (err > 0) then write (0,*) "An error has occurred in li_tendency_thickness." - endif + endif !-------------------------------------------------------------------- end subroutine li_tendency_thickness @@ -249,7 +258,7 @@ end subroutine li_tendency_thickness ! !----------------------------------------------------------------------- - subroutine li_tendency_tracers(mesh, state, layerThickness_tend, tracer_tendency, dt, dminfo, err) + subroutine li_tendency_tracers(meshPool, statePool, layerThickness_tend, tracer_tendency, dt, dminfo, err) !----------------------------------------------------------------- ! @@ -257,14 +266,14 @@ subroutine li_tendency_tracers(mesh, state, layerThickness_tend, tracer_tendency ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information - type (state_type), intent(in) :: & - state !< Input: state to use to calculate tendency + type (mpas_pool_type), intent(in) :: & + statePool !< Input: state to use to calculate tendency real (kind=RKIND), dimension(:,:), pointer, intent(in) :: & - layerThickness_tend !< Input/Output: layer thickness tendency + layerThickness_tend !< Input/Output: layer thickness tendency real (kind=RKIND), intent(in) :: & dt !< Input: dt @@ -396,7 +405,7 @@ end subroutine li_tendency_tracers !> marine-terminating ice. ! !----------------------------------------------------------------------- - subroutine li_apply_calving(mesh, state, err)!{{{ + subroutine li_apply_calving(meshPool, statePool, err)!{{{ !----------------------------------------------------------------- ! @@ -404,8 +413,8 @@ subroutine li_apply_calving(mesh, state, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -413,8 +422,8 @@ subroutine li_apply_calving(mesh, state, err)!{{{ ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - state !< Input/Output: state for which to update diagnostic variables + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state for which to update diagnostic variables !----------------------------------------------------------------- ! @@ -554,7 +563,9 @@ end subroutine li_apply_calving !> results. ! !----------------------------------------------------------------------- - subroutine tend_layerThickness_fo_upwind(mesh, normalVelocity, layerThicknessEdge, edgeMask, tend, dt, MinOfMaxAllowableDt, err)!{{{ + subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknessEdge, edgeMask, tend, dt, MinOfMaxAllowableDt, err)!{{{ + + use mpas_timekeeping !----------------------------------------------------------------- ! @@ -562,8 +573,8 @@ subroutine tend_layerThickness_fo_upwind(mesh, normalVelocity, layerThicknessEdg ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & normalVelocity !< Input: velocity @@ -600,25 +611,31 @@ subroutine tend_layerThickness_fo_upwind(mesh, normalVelocity, layerThicknessEdg ! !----------------------------------------------------------------- - integer :: nCells, nVertLevels, iEdge, iCell, i, k + integer, pointer :: nCells, nVertLevels integer, dimension(:,:), pointer :: edgesOnCell, edgeSignOnCell integer, dimension(:), pointer :: nEdgesOnCell - real (kind=RKIND) :: invAreaCell, flux, maxAllowableDt real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell, dcEdge + logical, pointer :: config_print_thickness_advection_info + real (kind=RKIND) :: invAreaCell, flux, maxAllowableDt + integer :: iEdge, iCell, i, k + type (MPAS_TimeInterval_type) :: allowableDtMinStringInterval + character (len=StrKIND) :: allowableDtMinString + integer :: err_tmp ! Only needed for optional check for mass conservation !real (kind=RKIND) :: tendVolSum err = 0 - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels - nEdgesOnCell => mesh % nEdgesOnCell % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnCell => mesh % edgeSignOnCell % array - dvEdge => mesh % dvEdge % array - dcEdge => mesh % dcEdge % array - areaCell => mesh % areaCell % array + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_config(liConfigs, 'config_print_thickness_advection_info', config_print_thickness_advection_info) MinOfMaxAllowableDt = 1.0e36_RKIND @@ -645,13 +662,20 @@ subroutine tend_layerThickness_fo_upwind(mesh, normalVelocity, layerThicknessEdg end do end do + ! Build a time string of the maximum allowable dt calculated + ! (We only need this if a CFL violation occurred or config_print_thickness_advection_info is true) + call mpas_set_timeInterval(allowableDtMinStringInterval, dt=MinOfMaxAllowableDt, ierr=err_tmp) + err = ior(err,err_tmp) + call mpas_get_timeInterval(allowableDtMinStringInterval, timeString=allowableDtMinString, ierr=err_tmp) + err = ior(err,err_tmp) + if (err > 0) then - write(0,*) 'CFL violation on this processor on ', err, ' level-edges! Maximum allowable time step (seconds) for this processor is ', MinOfMaxAllowableDt + write(0,*) 'CFL violation on this processor on ', err, ' level-edges! Maximum allowable time step (seconds) for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) err = 1 endif - if (config_print_thickness_advection_info .eqv. .true.) then - write(6,*) ' Maximum allowable time step (seconds) on this processor is ~', MinOfMaxAllowableDt + if (config_print_thickness_advection_info) then + write(6,*) ' Maximum allowable time step (s) on THIS processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) endif ! Optional check for mass conservation @@ -684,21 +708,21 @@ end subroutine tend_layerThickness_fo_upwind!}}} ! !----------------------------------------------------------------------- - subroutine tracer_advection_tend_fo(tracers, uh, mesh, tracer_tendency, err) + subroutine tracer_advection_tend_fo(tracers, uh, meshPool, tracer_tendency, err) !----------------------------------------------------------------- ! ! input variables ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:,:), intent(in) :: & - tracers !< Input: + tracers !< Input: real (kind=RKIND), dimension(:,:), intent(in) :: & - uh !< Input: + uh !< Input: !----------------------------------------------------------------- ! diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mpas_li_time_integration.F index 904fafd323..9010fb6cf1 100644 --- a/src/core_landice/mpas_li_time_integration.F +++ b/src/core_landice/mpas_li_time_integration.F @@ -26,6 +26,7 @@ module li_time_integration use mpas_constants use mpas_dmpar use li_time_integration_fe + use li_setup implicit none private @@ -64,9 +65,8 @@ module li_time_integration !> \date 20 April 2012 !> \details !> This routine advances model state forward in time by the specified time step. -!> Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:)) -!> plus mesh data -!> Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains +!> Input: domain - current model state in time level 1 plus mesh data +!> Output: domain - upon exit, time level 2 contains !> model state advanced forward in time by dt seconds !----------------------------------------------------------------------- subroutine li_timestep(domain, dt, timeStamp, err) @@ -99,12 +99,16 @@ subroutine li_timestep(domain, dt, timeStamp, err) ! !----------------------------------------------------------------- type (block_type), pointer :: block - type (state_type), pointer :: state + type (mpas_pool_type), pointer :: statePool + character (len=StrKIND), pointer :: xtime + character (len=StrKIND), pointer :: config_time_integration integer :: err_tmp err = 0 err_tmp = 0 + call mpas_pool_get_config(liConfigs, 'config_time_integration', config_time_integration) + !write(*,*) 'Using ', trim(config_time_integration), ' time integration.' select case (config_time_integration) case ('forward_euler') @@ -122,7 +126,9 @@ subroutine li_timestep(domain, dt, timeStamp, err) block => domain % blocklist do while (associated(block)) ! Assign the time stamp for this time step - block % state % time_levs(2) % state % xtime % scalar = timeStamp + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_array(statePool, 'xtime', xtime, timeLevel=1) ! xtime only has one time level, but stating is explicitly here to avoid confusion later. + xtime = timeStamp ! ! Abort the simulation if NaNs occur in the velocity field ! if (isNaN(sum(block % state % time_levs(2) % state % u % array))) then diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index ec47dc6572..c062ac0e43 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -31,6 +31,7 @@ module li_time_integration_fe use li_velocity, only: li_velocity_solve use li_tendency use li_diagnostic_vars + use li_setup implicit none private @@ -75,52 +76,32 @@ module li_time_integration_fe subroutine li_time_integrator_forwardeuler(domain, deltat, err) !----------------------------------------------------------------- - ! ! input variables - ! !----------------------------------------------------------------- real (kind=RKIND), intent(in) :: deltat !< Input: time step !----------------------------------------------------------------- - ! ! input/output variables - ! !----------------------------------------------------------------- - type (domain_type), intent(inout) :: & domain !< Input/Output: domain object !----------------------------------------------------------------- - ! ! output variables - ! !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- - ! ! local variables - ! !----------------------------------------------------------------- - type (dm_info), pointer :: dminfo type (block_type), pointer :: block - type (state_type), pointer :: stateOld, stateNew - type (mesh_type), pointer :: mesh - - real (kind=RKIND), dimension(:), pointer :: thicknessOld, thicknessNew, layerThicknessFractions, iceAreaOld, iceAreaNew, iceArea_tend - real (kind=RKIND), dimension(:,:), pointer :: normalVelocityOld, normalVelocityNew, layerThicknessOld, layerThicknessNew, layerThickness_tend - real (kind=RKIND), dimension(:,:,:), pointer :: tracer_tendency, tracersNew, tracersOld - integer, dimension(:), pointer :: cellMaskOld - integer :: nVertLevels, k, iEdge, iTracer integer :: err_tmp - + ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) ! (time level 1 should not be modified.) - dminfo => domain % dminfo !!! procVertexMaskChanged = 0 ! === Implicit column physics (vertical temperature diffusion) =========== @@ -185,45 +166,47 @@ end subroutine li_time_integrator_forwardeuler subroutine calculate_tendencies(domain, deltat, err) + use mpas_timekeeping + !----------------------------------------------------------------- - ! ! input variables - ! !----------------------------------------------------------------- - real (kind=RKIND) :: deltat !----------------------------------------------------------------- - ! ! input/output variables - ! !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain !< Input/Output: domain object !----------------------------------------------------------------- - ! ! output variables - ! !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- - ! ! local variables - ! !----------------------------------------------------------------- type (dm_info), pointer :: dminfo type (block_type), pointer :: block - type (state_type), pointer :: stateOld - type (mesh_type), pointer :: mesh + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: tendPool + real (kind=RKIND), dimension(:,:), pointer :: layerThickness_tend + type (field2DReal), pointer :: layerThickness_tend_field integer :: allowableDtProcNumber, allowableDtMinProcNumber real (kind=RKIND) :: allowableDt, allowableDtMin + logical, pointer :: config_print_thickness_advection_info + type (MPAS_TimeInterval_type) :: allowableDtMinStringInterval + character (len=StrKIND) :: allowableDtMinString + integer :: err_tmp + + integer :: y, m, d, hh, mm, ss err = 0 + call mpas_pool_get_config(liConfigs, 'config_print_thickness_advection_info', config_print_thickness_advection_info) + dminfo => domain % dminfo ! === @@ -231,20 +214,24 @@ subroutine calculate_tendencies(domain, deltat, err) ! === block => domain % blocklist do while (associated(block)) - mesh => block % mesh - stateOld => block % state % time_levs(1) % state - layerThickness_tend => block % tend % layerThickness % array + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_array(tendPool, 'layerThickness', layerThickness_tend) ! Calculate thickness tendency using state at time n ========= - call li_tendency_thickness(mesh, stateOld, layerThickness_tend, deltat, dminfo, allowableDt, err) + call li_tendency_thickness(meshPool, statePool, layerThickness_tend, deltat, dminfo, allowableDt, err_tmp) + err = ior(err,err_tmp) block => block % next end do ! Now that we have exited the block loop, do any needed halo updates. - ! update halos on thickness tend + ! update halos on thickness tend call mpas_timer_start("halo updates") - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % layerThickness) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + call mpas_pool_get_field(tendPool, 'layerThickness', layerThickness_tend_field) + call mpas_dmpar_exch_halo_field(layerThickness_tend_field) call mpas_timer_stop("halo updates") ! If we are printing advection debug information, @@ -260,7 +247,11 @@ subroutine calculate_tendencies(domain, deltat, err) allowableDtProcNumber = -1 endif call mpas_dmpar_max_int(dminfo, allowableDtProcNumber, allowableDtMinProcNumber) - write(6,*) ' Maximum allowable time step for all processors is:', allowableDtMin, ' Time step is limited by processor number ', allowableDtMinProcNumber + call mpas_set_timeInterval(allowableDtMinStringInterval, dt=allowableDtMin, ierr=err_tmp) + err = ior(err,err_tmp) + call mpas_get_timeInterval(allowableDtMinStringInterval, timeString=allowableDtMinString, ierr=err_tmp) + err = ior(err,err_tmp) + write(6,*) ' Maximum allowable time step (yr) for all processors is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) // ' Time step is limited by processor number ', allowableDtMinProcNumber endif if (err .gt. 0) then @@ -331,37 +322,29 @@ end subroutine calculate_tendencies subroutine update_prognostics(domain, deltat, err) !----------------------------------------------------------------- - ! ! input variables - ! !----------------------------------------------------------------- - real (kind=RKIND) :: deltat !----------------------------------------------------------------- - ! ! input/output variables - ! !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain !< Input/Output: domain object !----------------------------------------------------------------- - ! ! output variables - ! !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- - ! ! local variables - ! !----------------------------------------------------------------- type (dm_info), pointer :: dminfo type (block_type), pointer :: block - type (mesh_type), pointer :: mesh + type (mpas_pool_type), pointer :: meshPool, statePool, tendPool + integer, pointer :: nCells + logical, pointer :: config_print_thickness_advection_info + real (kind=RKIND), dimension(:), pointer :: thicknessNew, layerThicknessFractions real (kind=RKIND), dimension(:,:), pointer :: layerThicknessOld, layerThicknessNew, layerThickness_tend !!! real (kind=RKIND), dimension(:,:,:), pointer :: tracer_tendency, tracersNew, tracersOld @@ -371,25 +354,30 @@ subroutine update_prognostics(domain, deltat, err) err = 0 dminfo => domain % dminfo + call mpas_pool_get_config(liConfigs, 'config_print_thickness_advection_info', config_print_thickness_advection_info) block => domain % blocklist do while (associated(block)) ! Mesh information - mesh => block % mesh - layerThicknessFractions => mesh % layerThicknessFractions % array + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) ! State at time n - layerThicknessOld => block % state % time_levs(1) % state % layerThickness % array + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessOld, timeLevel=1) !!! tracersOld => stateOld % tracers % array !!! cellMaskOld => stateOld % cellMask % array ! State at time n+1 (advanced by dt by Forward Euler) - thicknessNew => block % state % time_levs(2) % state % thickness % array - layerThicknessNew => block % state % time_levs(2) % state % layerThickness % array + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, timeLevel=2) + call mpas_pool_get_array(statePool, 'thickness', thicknessNew, timeLevel=2) !!! tracersNew => stateNew % tracers % array ! Tendencies - layerThickness_tend => block % tend % layerThickness % array + call mpas_pool_get_array(tendPool, 'layerThickness', layerThickness_tend) !!! tracer_tendency => block % tend % tracers % array @@ -401,15 +389,15 @@ subroutine update_prognostics(domain, deltat, err) !!!stateNew % sup_thickness % array(1,:,:) = (stateOld % tracers % array(stateOld % index_temperature,:,:) * layerThicknessOld + tracer_tendency(stateOld % index_temperature, :, :) * dt / SecondsInYear) / (layerThicknessNew+1.0e-12) - layerThicknessNew = layerThicknessOld + layerThickness_tend * deltat - thicknessNew = sum(layerThicknessNew, 1) + layerThicknessNew = layerThicknessOld + layerThickness_tend * deltat + thicknessNew = sum(layerThicknessNew, 1) !Optionally print some information about the new thickness !print *, 'thickness_tend maxval:', maxval(thickness_tend(1:mesh % nCellsSolve)) !print *, 'thicknessOld maxval:', maxval(thicknessOld(1:mesh % nCellsSolve)) !print *, ' thicknessNew maxval:', maxval(thicknessNew(1:mesh % nCellsSolve)) - allocate(masktmp(mesh%nCells + 1)) + allocate( masktmp(nCells + 1) ) masktmp = 0 !!! ! if holding advance within initial extent of ice, set thickness to 0 anywhere it has expanded beyond initial extent diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index a438e3effc..d2853d0183 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -27,6 +27,7 @@ module li_velocity use mpas_configure !!! use li_lifev use li_sia + use li_setup implicit none private @@ -100,10 +101,13 @@ subroutine li_velocity_init(domain, err) ! local variables ! !----------------------------------------------------------------- + character (len=StrKIND), pointer :: config_velocity_solver integer :: err_tmp err = 0 + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + write(*,*) 'Using ', trim(config_velocity_solver), ' dynamical core.' select case (config_velocity_solver) case ('sia') @@ -172,9 +176,12 @@ subroutine li_velocity_block_init(block, err) ! local variables ! !----------------------------------------------------------------- + character (len=StrKIND), pointer :: config_velocity_solver err = 0 + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + select case (config_velocity_solver) case ('sia') call li_sia_block_init(block, err) @@ -212,7 +219,7 @@ end subroutine li_velocity_block_init !> This routine calls velocity solvers. ! !----------------------------------------------------------------------- - subroutine li_velocity_solve(mesh, state, err) + subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) use li_sia @@ -222,8 +229,10 @@ subroutine li_velocity_solve(mesh, state, err) ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in) :: timeLevel !< Input: Time level on which to calculate diagnostic variables !----------------------------------------------------------------- ! @@ -231,8 +240,8 @@ subroutine li_velocity_solve(mesh, state, err) ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - state !< Input: state information + type (mpas_pool_type), intent(inout) :: & + statePool !< Input: state information !----------------------------------------------------------------- ! @@ -247,25 +256,28 @@ subroutine li_velocity_solve(mesh, state, err) ! local variables ! !----------------------------------------------------------------- - integer :: iEdge, nEdges - real (kind=RKIND), dimension(:,:), pointer :: normalVelocity - integer, dimension(:), pointer :: edgeMask + character (len=StrKIND), pointer :: config_velocity_solver +! integer :: iEdge, nEdges +! real (kind=RKIND), dimension(:,:), pointer :: normalVelocity +! integer, dimension(:), pointer :: edgeMask err = 0 - nEdges = mesh % nEdges - normalVelocity => state % normalVelocity % array - edgeMask => state % edgeMask % array + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + +! nEdges = mesh % nEdges +! normalVelocity => state % normalVelocity % array +! edgeMask => state % edgeMask % array select case (config_velocity_solver) case ('sia') - call li_sia_solve(mesh, state, err) + call li_sia_solve(meshPool, statePool, timeLevel, err) !!! case ('L1L2') -!!! call li_lifev_solve(mesh, state, err) +!!! call li_lifev_solve(mesh, state, timeLevel, err) !!! case ('FO') -!!! call li_lifev_solve(mesh, state, err) +!!! call li_lifev_solve(mesh, state, timeLevel, err) !!! case ('Stokes') -!!! call li_lifev_solve(mesh, state, err) +!!! call li_lifev_solve(mesh, state, timeLevel, err) case default write(*,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 @@ -335,9 +347,12 @@ subroutine li_velocity_finalize(domain, err) ! local variables ! !----------------------------------------------------------------- + character (len=StrKIND), pointer :: config_velocity_solver err = 0 + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + select case (config_velocity_solver) case ('sia') call li_sia_finalize(domain, err) diff --git a/src/core_ocean/.gitignore b/src/core_ocean/.gitignore index e4eb1c9472..91183f2924 100644 --- a/src/core_ocean/.gitignore +++ b/src/core_ocean/.gitignore @@ -1,2 +1,9 @@ # Ignore all cvmix code. cvmix +.cvmix_all +.*.zip + +# Ignore processed registry files. +*/Registry_processed.xml + + diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index e2b113f76f..abfb491d2a 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -1,214 +1,86 @@ -.SUFFIXES: .F .o - -CVMIX_REPO_ADDRESS=http://cvmix.googlecode.com/svn/trunk/src/shared - -OBJS = mpas_ocn_mpas_core.o \ - mpas_ocn_thick_hadv.o \ - mpas_ocn_thick_vadv.o \ - mpas_ocn_thick_surface_flux.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_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_vmix.o \ - mpas_ocn_vmix_coefs_const.o \ - mpas_ocn_vmix_coefs_rich.o \ - mpas_ocn_vmix_coefs_tanh.o \ - mpas_ocn_vmix_cvmix.o \ - mpas_ocn_tendency.o \ - mpas_ocn_diagnostics.o \ - mpas_ocn_thick_ale.o \ - mpas_ocn_tracer_hmix.o \ - mpas_ocn_tracer_hmix_del2.o \ - mpas_ocn_tracer_hmix_del4.o \ - mpas_ocn_tracer_advection.o \ - mpas_ocn_tracer_short_wave_absorption.o \ - mpas_ocn_tracer_short_wave_absorption_jerlov.o \ - mpas_ocn_high_freq_thickness_hmix_del2.o \ - mpas_ocn_tracer_surface_flux.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_test.o \ - mpas_ocn_constants.o \ - mpas_ocn_forcing.o \ - mpas_ocn_forcing_bulk.o \ - mpas_ocn_forcing_restoring.o \ - mpas_ocn_time_average.o \ - mpas_ocn_time_average_coupled.o \ - mpas_ocn_sea_ice.o - -all: libcvmix core_hyd - -libcvmix: - if [ ! -d cvmix ]; then \ - (svn checkout $(CVMIX_REPO_ADDRESS) cvmix) \ - fi - if [ -d cvmix ]; then \ - (cd cvmix; svn update; make all FC="$(FC)" FFLAGS="$(FFLAGS)" FINCLUDES="$(FINCLUDES)") \ - fi - ln -sf cvmix/*.mod . - -core_hyd: $(OBJS) - ar -ru libdycore.a $(OBJS) cvmix/*.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_tendency.o mpas_ocn_diagnostics.o mpas_ocn_time_average_coupled.o mpas_ocn_sea_ice.o - -mpas_ocn_time_integration_split.o: mpas_ocn_tendency.o mpas_ocn_diagnostics.o mpas_ocn_time_average_coupled.o mpas_ocn_sea_ice.o - -mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_flux.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o - -mpas_ocn_diagnostics.o: mpas_ocn_time_average.o mpas_ocn_thick_ale.o - -mpas_ocn_thick_ale.o: - -mpas_ocn_global_diagnostics.o: - -mpas_ocn_time_average.o: - -mpas_ocn_time_average_coupled.o: mpas_ocn_constants.o - -mpas_ocn_thick_hadv.o: - -mpas_ocn_thick_vadv.o: - -mpas_ocn_thick_surface_flux.o: mpas_ocn_forcing.o +.SUFFIXES: .F .c .o -mpas_ocn_gm.o: +OCEAN_SHARED_INCLUDES=-I../shared -I../analysis_members -I../cvmix -I../../framework -I../../external/esmf_time_f90 -I../../operators -mpas_ocn_vel_pressure_grad.o: +OCEAN_LIBRARIES=cvmix/*.o analysis_members/*.o shared/*.o -mpas_ocn_vel_vadv.o: +ifdef MODE -mpas_ocn_vel_hmix.o: mpas_ocn_vel_hmix_del2.o mpas_ocn_vel_hmix_leith.o mpas_ocn_vel_hmix_del4.o +ifeq ($(wildcard ./mode_$(MODE)), ) # CHECK FOR EXISTENCE OF MODE DIRECTORY +all: exit -mpas_ocn_vel_hmix_del2.o: +core_reg: exit -mpas_ocn_vel_hmix_leith.o: +error_msg: error_head + @echo "$(MODE) is not a valid build mode for the ocean core" -mpas_ocn_vel_hmix_del4.o: +else # IFEQ ($(wildcard.... -mpas_ocn_vel_forcing.o: mpas_ocn_vel_forcing_windstress.o mpas_ocn_vel_forcing_rayleigh.o mpas_ocn_forcing.o - -mpas_ocn_vel_forcing_windstress.o: - -mpas_ocn_vel_forcing_rayleigh.o: - -mpas_ocn_vel_coriolis.o: - -mpas_ocn_tracer_hmix.o: mpas_ocn_tracer_hmix_del2.o mpas_ocn_tracer_hmix_del4.o - -mpas_ocn_tracer_hmix_del2.o: - -mpas_ocn_tracer_hmix_del4.o: - -mpas_ocn_tracer_advection.o: - -mpas_ocn_high_freq_thickness_hmix_del2.o: - -mpas_ocn_tracer_surface_flux.o: mpas_ocn_forcing.o - -mpas_ocn_tracer_short_wave_absorption.o: mpas_ocn_tracer_short_wave_absorption_jerlov.o - -mpas_ocn_tracer_short_wave_absorption_jerlov.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_vmix_cvmix.o +all: shared libcvmix analysis_members + (cd mode_$(MODE); $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" ) + if [ -e libdycore.a ]; then \ + ($(RM) libdycore.a) \ + fi + ar -ru libdycore.a $(OCEAN_LIBRARIES) mode_$(MODE)/*.o -mpas_ocn_vmix_coefs_const.o: +core_reg: + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml -mpas_ocn_vmix_coefs_rich.o: mpas_ocn_equation_of_state.o +endif # IFEQ ($(wildcard.... -mpas_ocn_vmix_coefs_tanh.o: +else # IFDEF MODE -mpas_ocn_vmix_cvmix.o: libcvmix +all: exit -mpas_ocn_equation_of_state.o: mpas_ocn_equation_of_state_jm.o mpas_ocn_equation_of_state_linear.o +core_reg: exit -mpas_ocn_equation_of_state_jm.o: +error_msg: error_head + @echo "The ocean core requires a build mode." -mpas_ocn_equation_of_state_linear.o: +endif # IFDEF MODE -mpas_ocn_test.o: +cvmix_source: get_cvmix.sh + (chmod a+x get_cvmix.sh; ./get_cvmix.sh) + (cd cvmix; make clean) -mpas_ocn_constants.o: +libcvmix: cvmix_source + if [ -d cvmix ]; then \ + (cd cvmix; make all FC="$(FC)" FCFLAGS="$(FFLAGS)" FINCLUDES="$(FINCLUDES)") \ + else \ + (exit 1) \ + fi -mpas_ocn_forcing.o: mpas_ocn_constants.o mpas_ocn_forcing_bulk.o mpas_ocn_forcing_restoring.o +shared: libcvmix + (cd shared; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)") -mpas_ocn_forcing_bulk.o: +analysis_members: libcvmix shared + ( cd analysis_members; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all ) -mpas_ocn_forcing_restoring.o: +error_head: + @echo "" + @echo "" + @echo "*************************************" + @echo "ERROR" -mpas_ocn_sea_ice.o: +error_tail: error_head error_msg + @echo "Available build modes are:" + @ls -d mode_* | grep ".*" | sed "s/mode_/ /g" + @echo "" + @echo "Please specify at build time as follows:" + @echo " make target CORE=ocean MODE=build_mode" + @echo "*************************************" + @echo "" + @echo "" -mpas_ocn_mpas_core.o: mpas_ocn_thick_hadv.o \ - mpas_ocn_thick_vadv.o \ - mpas_ocn_thick_surface_flux.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_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_hmix.o \ - mpas_ocn_tracer_hmix_del2.o \ - mpas_ocn_tracer_hmix_del4.o \ - mpas_ocn_high_freq_thickness_hmix_del2.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_vmix_cvmix.o \ - mpas_ocn_tracer_advection.o \ - mpas_ocn_tracer_surface_flux.o \ - mpas_ocn_tracer_short_wave_absorption.o \ - mpas_ocn_tracer_short_wave_absorption_jerlov.o \ - mpas_ocn_tendency.o \ - mpas_ocn_diagnostics.o \ - mpas_ocn_thick_ale.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_test.o \ - mpas_ocn_constants.o \ - mpas_ocn_forcing.o \ - mpas_ocn_forcing_bulk.o \ - mpas_ocn_forcing_restoring.o \ - mpas_ocn_time_average.o \ - mpas_ocn_time_average_coupled.o \ - mpas_ocn_sea_ice.o +exit: error_head error_msg error_tail + @exit 1 clean: if [ -d cvmix ]; then \ (cd cvmix; make clean) \ fi - $(RM) *.o *.mod *.f90 libdycore.a - -.F.o: - $(RM) $@ $*.mod -ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 -I./cvmix/ -else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 -I./cvmix/ -endif + (cd mode_forward; $(MAKE) clean) + (cd mode_analysis; $(MAKE) clean) + (cd analysis_members; $(MAKE) clean) + (cd shared; $(MAKE) clean) + ($(RM) *.mod libdycore.a Registry_processed.xml) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index f4ca8a405f..44d64ea3af 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,6 @@ - + + - + + - - - - - - - - - + - - - + - + - + - - + - + - - + @@ -228,11 +205,11 @@ possible_values="Any positive real number. If set any negative real number, config_maxMeshDensity is computed during the initialization of each simulation." /> - + - + - + - - + - + + + - + - + - + - + - + - @@ -349,17 +338,17 @@ description="Vertical viscosity, applied uniformly throughout domain" possible_values="Any positive real value." /> - - - + - @@ -376,7 +365,7 @@ possible_values="Any positive real value." /> - + - + - + + + + + + + + + + + + + - + + + + - + - @@ -498,7 +555,7 @@ possible_values=".true. or .false." /> - + - + - + + - + - - + - - @@ -559,12 +620,12 @@ description="Reference salinity" possible_values="any real" /> - - + - + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - + - - - + - - - + + + + + + - - - - - - - - - - + + - - - - + + - @@ -1102,10 +1542,9 @@ description="layer thickness averaged from cell center to vertices" /> - - @@ -1116,19 +1555,19 @@ description="kappaQ parameter for Gent-McWilliams eddy parameterization" /> - - - - - @@ -1148,22 +1586,36 @@ description="Barotropic thickness flux at each edge, used to advance sea surface height in each subcycle of stage 2 of the split-explicit algorithm." /> - - - - - + + + + + - @@ -1183,226 +1635,345 @@ description="Meridional Component of the gradient of sea surface height at cell centers." /> - - - - - - - - - - - - - - - - + + + + + + + - - - - - - - - + + + + + + + + + + + + + + + + + - - + - - - + - - + - - - + - + + + + + - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + - - - - - + + - - - - - + - - - - - - + + + + + + + + + + + + + + + + + + + + + + + - +#include "analysis_members/Registry_analysis_members.xml" diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile new file mode 100644 index 0000000000..00c20c2791 --- /dev/null +++ b/src/core_ocean/analysis_members/Makefile @@ -0,0 +1,25 @@ +.SUFFIXES: .F .o + +OBJS = mpas_ocn_analysis_driver.o \ + mpas_ocn_global_stats.o \ + mpas_ocn_zonal_mean.o + +all: $(OBJS) + +mpas_ocn_analysis_driver.o: mpas_ocn_global_stats.o mpas_ocn_zonal_mean.o + +mpas_ocn_global_stats.o: + +mpas_ocn_zonal_mean.o: + +clean: + $(RM) *.o *.i *.mod *.f90 lib*.a + +.F.o: + $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) +endif diff --git a/src/core_ocean/analysis_members/Registry_TEMPLATE.xml b/src/core_ocean/analysis_members/Registry_TEMPLATE.xml new file mode 100644 index 0000000000..e2a66059d7 --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_TEMPLATE.xml @@ -0,0 +1,38 @@ + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/Registry_analysis_members.xml b/src/core_ocean/analysis_members/Registry_analysis_members.xml new file mode 100644 index 0000000000..967676d3e7 --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_analysis_members.xml @@ -0,0 +1,2 @@ +#include "Registry_global_stats.xml" +#include "Registry_zonal_mean.xml" diff --git a/src/core_ocean/analysis_members/Registry_global_stats.xml b/src/core_ocean/analysis_members/Registry_global_stats.xml new file mode 100644 index 0000000000..6afe97b96d --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_global_stats.xml @@ -0,0 +1,417 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/Registry_zonal_mean.xml b/src/core_ocean/analysis_members/Registry_zonal_mean.xml new file mode 100644 index 0000000000..826724a929 --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_zonal_mean.xml @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_TEMPLATE.F b/src/core_ocean/analysis_members/mpas_ocn_TEMPLATE.F new file mode 100644 index 0000000000..6c3dca1d9a --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_TEMPLATE.F @@ -0,0 +1,484 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_TEMPLATE +! +!> \brief MPAS ocean analysis core member: TEMPLATE +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> MPAS ocean analysis core member: TEMPLATE +!> In order to add a new analysis member, do the following: +!> 1. Copy these to your new analysis member name: +!> cp mpas_ocn_TEMPLATE.F mpas_ocn_your_new_name.F +!> cp Registry_ocn_TEMPLATE.xml Registry_ocn_your_new_name.xml +!> +!> 2. In those two new files, replace the following text: +!> TEMPLATE, amTemplate, FILL_IN_AUTHOR, FILL_IN_DATE +!> Note TEMPLATE uses underscores, like global_stats, while +!> amTemplate uses caps, e.g. amGlobalStats. +!> +!> 3. Add a #include line for your registry to +!> Registry_analysis_members.xml +!> +!> 4. In mpas_ocn_analysis_driver.F, add calls for your analysis member +!> by copying lines with TEMPLATE. +!> +!> 5. In src/core_ocean/analysis_members/Makefile, add your +!> new analysis member everywhere you see +!> mpas_ocn_global_stats.o +!> +! +!----------------------------------------------------------------------- + +module ocn_TEMPLATE + + use mpas_grid_types + use mpas_timer + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_diagnostics_routines + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_setup_packages_TEMPLATE, & + ocn_init_TEMPLATE, & + ocn_init_alarms_TEMPLATE, & + ocn_compute_TEMPLATE, & + ocn_restart_TEMPLATE, & + ocn_finalize_TEMPLATE + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + type (timer_node), pointer :: amTemplateTimer + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_setup_packages_TEMPLATE +! +!> \brief Set up packages for MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine is intended to configure the packages for this MPAS +!> ocean analysis member +! +!----------------------------------------------------------------------- + + subroutine ocn_setup_packages_TEMPLATE(configPool, packagePool, err)!{{{ + + use mpas_packages + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + logical, pointer :: amTemplateActive + + err = 0 + + call mpas_pool_get_package(packagePool, 'amTemplateActive', amTemplateActive) + + ! turn on package for this analysis member + amTemplateActive = .true. + + end subroutine ocn_setup_packages_TEMPLATE!}}} + + +!*********************************************************************** +! +! routine ocn_init_TEMPLATE +! +!> \brief Initialize MPAS-Ocean analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_TEMPLATE(domain, err)!{{{ + + use mpas_packages + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_init_TEMPLATE!}}} + +!*********************************************************************** +! +! routine ocn_init_alarms_TEMPLATE +! +!> \brief Initialize alarms for MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine conducts all alarm initializations required for the +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_alarms_TEMPLATE(clock, startTime, computeAlarmID, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: computeAlarmID + type (MPAS_Time_Type), intent(in) :: startTime + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (MPAS_Clock_type), intent(inout) :: clock + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: ierr + character(len=StrKIND) :: compute_interval + type (MPAS_Time_Type) :: alarmStartTime + type (MPAS_TimeInterval_type) :: alarmTimeStep + + character (len=StrKIND), pointer :: config_TEMPLATE_compute_interval, config_output_interval + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_TEMPLATE_compute_interval', config_TEMPLATE_compute_interval) + call mpas_pool_get_config(ocnConfigs, 'config_output_interval', config_output_interval) + + ! set compute alarm for this analysis member + if (config_TEMPLATE_compute_interval=='same_as_output') then + compute_interval = config_output_interval + else + compute_interval = config_TEMPLATE_compute_interval + endif + + call mpas_set_timeInterval(alarmTimeStep, timeString=compute_interval, ierr=ierr) + alarmStartTime = startTime + alarmTimeStep + call mpas_add_clock_alarm(clock, computeAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) + + end subroutine ocn_init_alarms_TEMPLATE!}}} + +!*********************************************************************** +! +! routine ocn_compute_TEMPLATE +! +!> \brief Compute MPAS-Ocean analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_compute_TEMPLATE(domain, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: amTemplatePool + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: amTemplate + + ! Here are some example variables which may be needed for your analysis member + integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, num_tracers + integer :: iTracer, k, iCell + integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot + + real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge + + err = 0 + + dminfo = domain % dminfo + + call mpas_timer_start("compute_TEMPLATE", .false., amTemplateTimer) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'amTemplate', amTemplatePool) + + ! Here are some example variables which may be needed for your analysis member + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) + + ! Computations which are functions of nCells, nEdges, or nVertices + ! must be placed within this block loop + ! Here are some example loops + do iCell = 1,nCellsSolve + do k = 1, maxLevelCell(iCell) + do iTracer = 1, num_tracers + ! computations on tracers(iTracer,k, iCell) + end do + end do + end do + + block => block % next + end do + + ! mpi gather/scatter calls may be placed here. + ! Here are some examples. See mpas_oac_global_stats.F for further details. +! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) +! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) +! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) + + ! Even though some variables do not include an index that is decomposed amongst + ! domain partitions, we assign them within a block loop so that all blocks have the + ! correct values for writing output. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'amTemplate', amTemplatePool) + + ! assignment of final amTemplate variables could occur here. + + block => block % next + end do + + call mpas_timer_stop("TEMPLATE", amTemplateTimer) + + end subroutine ocn_compute_TEMPLATE!}}} + +!*********************************************************************** +! +! routine ocn_restart_TEMPLATE +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_restart_TEMPLATE(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_restart_TEMPLATE!}}} + +!*********************************************************************** +! +! routine ocn_finalize_TEMPLATE +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_finalize_TEMPLATE(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_finalize_TEMPLATE!}}} + +end module ocn_TEMPLATE + +! vim: foldmethod=marker diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F new file mode 100644 index 0000000000..34fc6a62b1 --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -0,0 +1,640 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_analysis_driver +! +!> \brief Driver for MPAS ocean analysis core +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This is the driver for the MPAS ocean core. +! +!----------------------------------------------------------------------- + +module ocn_analysis_driver + + use mpas_grid_types + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_global_stats + use ocn_zonal_mean +! use ocn_TEMPLATE + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_analysis_setup_packages, & + ocn_analysis_init, & + ocn_analysis_compute_startup, & + ocn_analysis_compute, & + ocn_analysis_compute_w_alarms, & + ocn_analysis_write, & + ocn_analysis_restart, & + ocn_analysis_finalize + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_analysis_setup_packages +! +!> \brief Setup packages for MPAS-Ocean analysis driver +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine is intended to configure the packages for all +!> ocean analysis members. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_setup_packages(configPool, packagePool, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + logical, pointer :: config_use_global_stats, config_use_zonal_mean +! logical, pointer :: config_use_TEMPLATE + + err = 0 + + + call mpas_pool_get_config(configPool, 'config_use_global_stats', config_use_global_stats) + if (config_use_global_stats) then + call ocn_setup_packages_global_stats(configPool, packagePool, err_tmp) + err = ior(err, err_tmp) + endif + + call mpas_pool_get_config(configPool, 'config_use_zonal_mean', config_use_zonal_mean) + if (config_use_zonal_mean) then + call ocn_setup_packages_zonal_mean(configPool, packagePool, err_tmp) + err = ior(err, err_tmp) + endif + +! call mpas_pool_get_config(configPool, 'config_use_TEMPLATE', config_use_TEMPLATE) +! if (config_use_TEMPLATE) then +! call ocn_setup_packages_TEMPLATE(configPool, packagePool, err_tmp) +! err = ior(err, err_tmp) +! endif + + end subroutine ocn_analysis_setup_packages!}}} + +!*********************************************************************** +! +! routine ocn_analysis_init +! +!> \brief Initialize MPAS-Ocean analysis driver +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all initializations required for the +!> MPAS-Ocean analysis driver. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_init(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + logical, pointer :: config_use_global_stats, config_use_zonal_mean +! logical, pointer :: config_use_TEMPLATE + + err = 0 + + call mpas_pool_get_config(domain % configs, 'config_use_global_stats', config_use_global_stats) + if (config_use_global_stats) then + call ocn_init_global_stats(domain, err_tmp) + err = ior(err, err_tmp) + endif + + call mpas_pool_get_config(domain % configs, 'config_use_zonal_mean', config_use_zonal_mean) + if (config_use_zonal_mean) then + call ocn_init_zonal_mean(domain, err_tmp) + err = ior(err, err_tmp) + endif + +! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) +! if (config_use_TEMPLATE) then +! call ocn_init_TEMPLATE(domain, err_tmp) +! err = ior(err, err_tmp) +! endif + + end subroutine ocn_analysis_init!}}} + +!*********************************************************************** +! +! routine ocn_analysis_compute_startup +! +!> \brief Driver for MPAS-Ocean analysis computations +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all computation subroutines required for the +!> MPAS-Ocean analysis driver. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_compute_startup(domain, stream_manager, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + type (mpas_streamManager_type), intent(inout) :: stream_manager + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: timeLevel, err_tmp + + logical, pointer :: config_use_global_stats, config_global_stats_compute_startup + logical, pointer :: config_use_zonal_mean, config_zonal_mean_compute_startup +! logical, pointer :: config_use_TEMPLATE, config_TEMPLATE_compute_startup + + err = 0 + + timeLevel=1 + call mpas_pool_get_config(domain % configs, 'config_use_global_stats', config_use_global_stats) + call mpas_pool_get_config(domain % configs, 'config_global_stats_compute_startup', config_global_stats_compute_startup) + if (config_use_global_stats.and.config_global_stats_compute_startup) then + call ocn_compute_global_stats(domain, timeLevel, err_tmp) + call mpas_stream_mgr_write(stream_manager, streamID='globalStatsOutput', forceWriteNow=.true., ierr=err_tmp) + err = ior(err, err_tmp) + endif + + call mpas_pool_get_config(domain % configs, 'config_use_zonal_mean', config_use_zonal_mean) + call mpas_pool_get_config(domain % configs, 'config_zonal_mean_compute_startup', config_zonal_mean_compute_startup) + if (config_use_zonal_mean.and.config_zonal_mean_compute_startup) then + call ocn_compute_zonal_mean(domain, timeLevel, err_tmp) + call mpas_stream_mgr_write(stream_manager, streamID='zonalMeanOutput', forceWriteNow=.true., ierr=err_tmp) + err = ior(err, err_tmp) + endif + +! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) +! call mpas_pool_get_config(domain % configs, 'config_TEMPLATE_compute_startup', config_TEMPLATE_compute_startup) +! if (config_use_TEMPLATE.and.config_TEMPLATE_compute_startup) then +! call ocn_compute_TEMPLATE(domain, timeLevel, err_tmp) +! err = ior(err, err_tmp) +! endif + + end subroutine ocn_analysis_compute_startup!}}} + +!*********************************************************************** +! +! routine ocn_analysis_compute +! +!> \brief Driver for MPAS-Ocean analysis computations +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all computation subroutines required for the +!> MPAS-Ocean analysis driver. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_compute(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: timeLevel, err_tmp + + logical, pointer :: config_use_global_stats, config_use_zonal_mean +! logical, pointer :: config_use_TEMPLATE + + err = 0 + + timeLevel=1 + call mpas_pool_get_config(domain % configs, 'config_use_global_stats', config_use_global_stats) + if (config_use_global_stats) then + call ocn_compute_global_stats(domain, timeLevel, err_tmp) + endif + + call mpas_pool_get_config(domain % configs, 'config_use_zonal_mean', config_use_zonal_mean) + if (config_use_zonal_mean) then + call ocn_compute_zonal_mean(domain, timeLevel, err_tmp) + endif + +! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) +! if (config_use_TEMPLATE) then +! call ocn_compute_TEMPLATE(domain, timeLevel, err_tmp) +! endif + + end subroutine ocn_analysis_compute!}}} + +!*********************************************************************** +! +! routine ocn_analysis_compute_w_alarms +! +!> \brief Driver for MPAS-Ocean analysis computations +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all computation subroutines required for the +!> MPAS-Ocean analysis driver. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_compute_w_alarms(stream_manager, domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (MPAS_streamManager_type), intent(inout) :: stream_manager + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: timeLevel, err_tmp + logical, pointer :: config_use_global_stats, config_use_zonal_mean +! logical, pointer :: config_use_TEMPLATE + + err = 0 + + timeLevel=1 + call mpas_pool_get_config(domain % configs, 'config_use_global_stats', config_use_global_stats) + if (config_use_global_stats) then + if (mpas_stream_mgr_ringing_alarms(stream_manager, streamID='globalStatsOutput', direction=MPAS_STREAM_OUTPUT, ierr=err_tmp)) then + call ocn_compute_global_stats(domain, timeLevel, err_tmp) + endif + endif + + call mpas_pool_get_config(domain % configs, 'config_use_zonal_mean', config_use_zonal_mean) + if (config_use_zonal_mean) then + if (mpas_stream_mgr_ringing_alarms(stream_manager, streamID='zonalMeanOutput', direction=MPAS_STREAM_OUTPUT, ierr=err_tmp)) then + call ocn_compute_zonal_mean(domain, timeLevel, err_tmp) + endif + endif + +! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) +! if (config_use_TEMPLATE) then +! if (mpas_stream_mgr_ringing_alarms(stream_manager, streamID='TEMPLATEOutput', direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) then +! call ocn_compute_TEMPLATE(domain, timeLevel, err_tmp) +! endif +! endif + + end subroutine ocn_analysis_compute_w_alarms!}}} + +!*********************************************************************** +! +! routine ocn_analysis_restart +! +!> \brief Save restart for MPAS-Ocean analysis driver +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all subroutines required to prepare to save +!> the restart state for the MPAS-Ocean analysis driver. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_restart(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + logical, pointer :: config_use_global_stats, config_use_zonal_mean +! logical, pointer :: config_use_TEMPLATE + + err = 0 + + call mpas_pool_get_config(domain % configs, 'config_use_global_stats', config_use_global_stats) + if (config_use_global_stats) then + call ocn_restart_global_stats(domain, err_tmp) + err = ior(err, err_tmp) + endif + + call mpas_pool_get_config(domain % configs, 'config_use_zonal_mean', config_use_zonal_mean) + if (config_use_zonal_mean) then + call ocn_restart_zonal_mean(domain, err_tmp) + err = ior(err, err_tmp) + endif + +! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) +! if (config_use_TEMPLATE) then +! call ocn_restart_TEMPLATE(domain, err_tmp) +! err = ior(err, err_tmp) +! endif + + end subroutine ocn_analysis_restart!}}} + +!*********************************************************************** +! +! routine ocn_analysis_write +! +!> \brief Driver for MPAS-Ocean analysis output +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all output writing subroutines required for the +!> MPAS-Ocean analysis driver. +!> At this time this is just a stub, and all analysis output is written +!> to the output file specified by config_output_name. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_write(stream_manager, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (MPAS_streamManager_type), intent(inout) :: stream_manager + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + + logical, pointer :: config_use_global_stats, config_use_zonal_mean +! logical, pointer :: config_use_TEMPLATE + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_global_stats', config_use_global_stats) + if (config_use_global_stats) then + call mpas_stream_mgr_write(stream_manager, streamID='globalStatsOutput', ierr=err_tmp) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='globalStatsOutput', ierr=err_tmp) + err = ior(err, err_tmp) + endif + + call mpas_pool_get_config(ocnConfigs, 'config_use_zonal_mean', config_use_zonal_mean) + if (config_use_zonal_mean) then + call mpas_stream_mgr_write(stream_manager, streamID='zonalMeanOutput', ierr=err_tmp) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='zonalMeanOutput', ierr=err_tmp) + endif + +! call mpas_pool_get_config(ocnConfigs, 'config_use_TEMPLATE', config_use_TEMPLATE) +! if (config_use_TEMPLATE) then +! call mpas_stream_mgr_write(stream_manager, streamID='TEMPLATEOutput', ierr=err_tmp) +! call mpas_stream_mgr_reset_alarms(stream_manager, streamID='TEMPLATEOutput', ierr=err_tmp) +! err = ior(err, err_tmp) +! endif + + end subroutine ocn_analysis_write!}}} + +!*********************************************************************** +! +! routine ocn_analysis_finalize +! +!> \brief Finalize MPAS-Ocean analysis driver +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all finalize routines required for the +!> MPAS-Ocean analysis driver. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_finalize(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + logical, pointer :: config_use_global_stats, config_use_zonal_mean +! logical, pointer :: config_use_TEMPLATE + + err = 0 + + call mpas_pool_get_config(domain % configs, 'config_use_global_stats', config_use_global_stats) + if (config_use_global_stats) then + call ocn_finalize_global_stats(domain, err_tmp) + err = ior(err, err_tmp) + endif + + call mpas_pool_get_config(domain % configs, 'config_use_zonal_mean', config_use_zonal_mean) + if (config_use_zonal_mean) then + call ocn_finalize_zonal_mean(domain, err_tmp) + err = ior(err, err_tmp) + endif + +! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) +! if (config_use_TEMPLATE) then +! call ocn_finalize_TEMPLATE(domain, err_tmp) +! err = ior(err, err_tmp) +! endif + + end subroutine ocn_analysis_finalize!}}} + +end module ocn_analysis_driver + +! vim: foldmethod=marker diff --git a/src/core_ocean/analysis_members/mpas_ocn_global_stats.F b/src/core_ocean/analysis_members/mpas_ocn_global_stats.F new file mode 100644 index 0000000000..77b4d443ca --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_global_stats.F @@ -0,0 +1,868 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_global_stats +! +!> \brief MPAS ocean analysis core member: global statistics +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> MPAS ocean analysis core member: global statistics +! +!----------------------------------------------------------------------- + +module ocn_global_stats + + use mpas_grid_types + use mpas_timer + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_diagnostics_routines + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_setup_packages_global_stats, & + ocn_init_global_stats, & + ocn_compute_global_stats, & + ocn_restart_global_stats, & + ocn_finalize_global_stats + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + type (timer_node), pointer :: amGlobalStatsTimer + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_setup_packages_global_stats +! +!> \brief Set up packages for MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine is intended to configure the packages for this MPAS +!> ocean analysis member +! +!----------------------------------------------------------------------- + + subroutine ocn_setup_packages_global_stats(configPool, packagePool, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + logical, pointer :: amGlobalStatsActive + + err = 0 + + call mpas_pool_get_package(packagePool, 'amGlobalStatsActive', amGlobalStatsActive) + + ! turn on package for this analysis member + amGlobalStatsActive = .true. + + end subroutine ocn_setup_packages_global_stats!}}} + + +!*********************************************************************** +! +! routine ocn_init_global_stats +! +!> \brief Initialize MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_global_stats(domain, err)!{{{ + + use mpas_packages + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_init_global_stats!}}} + +!*********************************************************************** +! +! routine ocn_compute_global_stats +! +!> \brief Compute MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: amGlobalStatsPool + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + + integer :: err_tmp + integer :: nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer + integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins + integer :: k, i, fileID + integer :: timeYYYY, timeMM, timeDD, timeH, timeM, timeS + integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, num_tracers + character*1 timeChar + integer, parameter :: kMaxVariables = 1024 ! this must be a little more than double the number of variables to be reduced + integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot + + character (len=StrKIND), pointer :: xtime + + real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal, localCFL, localSum, areaCellGlobal, areaEdgeGlobal, areaTriangleGlobal, time_days + real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, areaTriangle, areaEdge + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, normalVelocity, tangentialVelocity, layerThicknessEdge, relativeVorticity, kineticEnergyCell, & + normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, pressure, montgomeryPotential, vertAleTransportTop, vertVelocityTop, & + lowFreqDivergence, highFreqThickness, density + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + real (kind=RKIND), dimension(:), pointer :: minGlobalStats,maxGlobalStats,sumGlobalStats, averages, rms, verticalSumMins, verticalSumMaxes + real (kind=RKIND), dimension(kMaxVariables) :: sumSquares, reductions, sums, mins, maxes + real (kind=RKIND), dimension(kMaxVariables) :: sums_tmp, sumSquares_tmp, mins_tmp, maxes_tmp, averages_tmp, verticalSumMins_tmp, verticalSumMaxes_tmp + + real (kind=RKIND), dimension(:,:), allocatable :: enstrophy, normalizedAbsoluteVorticity, workArray + + logical, pointer :: thicknessFilterActive, amGlobalStatsActive + + err = 0 + + call mpas_pool_get_package(ocnPackages, 'amGlobalStatsActive', amGlobalStatsActive) + + if ( .not. amGlobalStatsActive ) return + + dminfo = domain % dminfo + + call mpas_timer_start("compute_global_stats", .false., amGlobalStatsTimer) + + call mpas_pool_get_package(ocnPackages, 'thicknessFilterActive', thicknessFilterActive) + + ! write out data to Analysis Member output + call mpas_pool_get_subpool(domain % blocklist % structs, 'amGlobalStats', amGlobalStatsPool) + call mpas_pool_get_array(amGlobalStatsPool, 'minGlobalStats', minGlobalStats) + call mpas_pool_get_array(amGlobalStatsPool, 'maxGlobalStats', maxGlobalStats) + call mpas_pool_get_array(amGlobalStatsPool, 'sumGlobalStats', sumGlobalStats) + call mpas_pool_get_array(amGlobalStatsPool, 'rmsGlobalStats', rms) + call mpas_pool_get_array(amGlobalStatsPool, 'avgGlobalStats', averages) + call mpas_pool_get_array(amGlobalStatsPool, 'vertSumMinGlobalStats', verticalSumMins) + call mpas_pool_get_array(amGlobalStatsPool, 'vertSumMaxGlobalStats', verticalSumMaxes) + + sums = 0.0 + sumSquares = 0.0 + mins = 1.0e34 + maxes = -1.0e34 + averages = 0.0 + verticalSumMins = 1.0e34 + verticalSumMaxes = -1.0e34 + reductions = 0.0 + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'amGlobalStats', amGlobalStatsPool) + + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(statePool, 'tracers', tracers) + if(thicknessFilterActive) then + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergence) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThickness) + end if + + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'montgomeryPotential', montgomeryPotential) + call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) + call mpas_pool_get_array(diagnosticsPool, 'relativeVorticity', relativeVorticity) + call mpas_pool_get_array(diagnosticsPool, 'normalizedRelativeVorticityEdge', normalizedRelativeVorticityEdge) + call mpas_pool_get_array(diagnosticsPool, 'normalizedPlanetaryVorticityEdge', normalizedPlanetaryVorticityEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertAleTransportTop', vertAleTransportTop) + call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'tangentialVelocity', tangentialVelocity) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) + + call mpas_pool_get_array(diagnosticsPool, 'xtime', xtime) + + allocate(areaEdge(1:nEdgesSolve)) + areaEdge = dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve) + + allocate(workArray(nVertLevels,nCellsSolve)) + + variableIndex = 0 + ! layerThickness + variableIndex = variableIndex + 1 + call ocn_compute_field_area_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! normalVelocity + variableIndex = variableIndex + 1 + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nEdgesSolve, maxLevelEdgeTop(1:nEdgesSolve), areaEdge(1:nEdgesSolve), layerThicknessEdge(:,1:nEdgesSolve), & + normalVelocity(:,1:nEdgesSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! tangentialVelocity + variableIndex = variableIndex + 1 + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nEdgesSolve, maxLevelEdgeTop(1:nEdgesSolve), areaEdge(1:nEdgesSolve), layerThicknessEdge(:,1:nEdgesSolve), & + tangentialVelocity(:,1:nEdgesSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! layerThicknessEdge + variableIndex = variableIndex + 1 + call ocn_compute_field_area_weighted_local_stats_max_level(dminfo, nVertLevels, nEdgesSolve, maxLevelEdgeTop(1:nEdgesSolve), areaEdge(1:nEdgesSolve), layerThicknessEdge(:,1:nEdgesSolve), & + sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! relativeVorticity + variableIndex = variableIndex + 1 + call ocn_compute_field_area_weighted_local_stats_max_level(dminfo, nVertLevels, nVerticesSolve, maxLevelVertexBot(1:nVerticesSolve), areaTriangle(1:nVerticesSolve), relativeVorticity(:,1:nVerticesSolve), & + sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! enstrophy + allocate(enstrophy(nVertLevels,nVerticesSolve)) + enstrophy(:,:)=relativeVorticity(:,1:nVerticesSolve)**2 + variableIndex = variableIndex + 1 + call ocn_compute_field_area_weighted_local_stats_max_level(dminfo, nVertLevels, nVerticesSolve, maxLevelVertexBot(1:nVerticesSolve), areaTriangle(1:nVerticesSolve), & + enstrophy(:,:), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), & + verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex)) + deallocate(enstrophy) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! kineticEnergyCell + variableIndex = variableIndex + 1 + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + kineticEnergyCell(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! normalizedAbsoluteVorticity + allocate(normalizedAbsoluteVorticity(nVertLevels,nEdgesSolve)) + normalizedAbsoluteVorticity(:,:) = normalizedRelativeVorticityEdge(:,1:nEdgesSolve) + normalizedPlanetaryVorticityEdge(:,1:nEdgesSolve) + variableIndex = variableIndex + 1 + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nEdgesSolve, maxLevelEdgeTop(1:nEdgesSolve), areaEdge(1:nEdgesSolve), layerThicknessEdge(:,1:nEdgesSolve), & + normalizedAbsoluteVorticity(:,1:nEdgesSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + deallocate(normalizedAbsoluteVorticity) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! pressure + variableIndex = variableIndex + 1 + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + pressure(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! montgomeryPotential + variableIndex = variableIndex + 1 + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + montgomeryPotential(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! vertVelocityTop vertical velocity + variableIndex = variableIndex + 1 + workArray = vertVelocityTop(1:nVertLevels,1:nCellsSolve) + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + workArray, sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! vertAleTransportTop vertical velocity + variableIndex = variableIndex + 1 + workArray = vertAleTransportTop(1:nVertLevels,1:nCellsSolve) + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + workArray, sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + + ! lowFreqDivergence + variableIndex = variableIndex + 1 + if (thicknessFilterActive) then + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + lowFreqDivergence(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + end if + + ! highFreqThickness + variableIndex = variableIndex + 1 + if (thicknessFilterActive) then + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + highFreqThickness(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + end if + + ! Tracers + do iTracer=1,num_tracers + variableIndex = variableIndex + 1 + workArray = Tracers(iTracer,:,1:nCellsSolve) + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + workArray, sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + enddo + deallocate(workArray) + + nVariables = variableIndex + nSums = nVariables + nMins = nVariables + nMaxes = nVariables + + nSums = nSums + 1 + sums(nSums) = sums(nSums) + sum(areaCell(1:nCellsSolve)) + + nSums = nSums + 1 + sums(nSums) = sums(nSums) + sum(dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve)) + + nSums = nSums + 1 + sums(nSums) = sums(nSums) + sum(areaTriangle(1:nVerticesSolve)) + + nSums = nSums + 1 + sums(nSums) = sums(nSums) + nCellsSolve + + nSums = nSums + 1 + sums(nSums) = sums(nSums) + nEdgesSolve + + nSums = nSums + 1 + sums(nSums) = sums(nSums) + nVerticesSolve + + localCFL = 0.0 + do elementIndex = 1,nEdgesSolve + ! note: dt not connected. dt will not be available in post processing mode. + !localCFL = max(localCFL, maxval(dt*normalVelocity(:,elementIndex)/dcEdge(elementIndex))) + end do + nMaxes = nMaxes + 1 + maxes(nMaxes) = localCFL + + do i = 1, nVariables + mins(nMins+i) = min(mins(nMins+i),verticalSumMins_tmp(i)) + maxes(nMaxes+i) = max(maxes(nMaxes+i),verticalSumMaxes_tmp(i)) + end do + + nMins = nMins + nVariables + nMaxes = nMaxes + nVariables + + deallocate(areaEdge) + + block => block % next + end do + + ! global reduction of the 5 arrays (packed into 3 to minimize global communication) + call mpas_dmpar_sum_real_array(dminfo, nSums, sums(1:nSums), reductions(1:nSums)) + sums(1:nVariables) = reductions(1:nVariables) + areaCellGlobal = reductions(nVariables+1) + areaEdgeGlobal = reductions(nVariables+2) + areaTriangleGlobal = reductions(nVariables+3) + nCellsGlobal = int(reductions(nVariables+4)) + nEdgesGlobal = int(reductions(nVariables+5)) + nVerticesGlobal = int(reductions(nVariables+6)) + call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) + sumSquares(1:nVariables) = reductions(1:nVariables) + + call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) + mins(1:nVariables) = reductions(1:nVariables) + verticalSumMins(1:nVariables) = reductions(nMins-nVariables+1:nMins) + + call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) + maxes(1:nVariables) = reductions(1:nVariables) + CFLNumberGlobal = reductions(nVariables+1) + verticalSumMaxes(1:nVariables) = reductions(nMaxes-nVariables+1:nMaxes) + + volumeCellGlobal = sums(1) + volumeEdgeGlobal = sums(4) + + ! compute the averages (slightly different depending on how the sum was computed) + variableIndex = 0 + + ! time, in days, using a 360 day calendar + read (xtime, '(i4,10(a1,i2))') timeYYYY, timeChar, timeMM, timeChar, timeDD, timeChar, timeH, timeChar, timeM, timeChar, timeS + ! subtract 31.0 because calendar starts on 00-01-01 + time_days = timeYYYY*360.0 + timeMM*30.0 + timeDD + (timeH + (timeM + timeS/60.0)/60.0)/24.0 - 31.0 + + ! layerThickness + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/(areaCellGlobal*nVertLevels) + rms(variableIndex) = sqrt(sumSquares(variableIndex)/(areaCellGlobal*nVertLevels)) + + ! normalVelocity + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeEdgeGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeEdgeGlobal) + + ! tangentialVelocity + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeEdgeGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeEdgeGlobal) + + ! layerThicknessEdge + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/(areaEdgeGlobal*nVertLevels) + rms(variableIndex) = sqrt(sumSquares(variableIndex)/(areaEdgeGlobal*nVertLevels)) + + ! relativeVorticity + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/(areaTriangleGlobal*nVertLevels) + rms(variableIndex) = sqrt(sumSquares(variableIndex)/(areaTriangleGlobal*nVertLevels)) + + ! enstrophy + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/(areaTriangleGlobal*nVertLevels) + rms(variableIndex) = sqrt(sumSquares(variableIndex)/(areaTriangleGlobal*nVertLevels)) + + ! kineticEnergyCell + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + + ! normalizedAbsoluteVorticity + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeEdgeGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeEdgeGlobal) + + ! pressure + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + + ! montgomeryPotential + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + + ! vertVelocityTop vertical velocity + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + + ! vertAleTransportTop vertical velocity + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + + if (thicknessFilterActive) then + ! lowFreqDivergence + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + + ! highFreqThickness + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + else + ! lowFreqDivergence + variableIndex = variableIndex + 1 + averages(variableIndex) = 0.0_RKIND + rms(variableIndex) = 0.0_RKIND + + ! highFreqThickness + variableIndex = variableIndex + 1 + averages(variableIndex) = 0.0_RKIND + rms(variableIndex) = 0.0_RKIND + end if + + ! Tracers + do iTracer=1,num_tracers + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + enddo + + minGlobalStats(1:nVariables) = mins(1:nVariables) + maxGlobalStats(1:nVariables) = maxes(1:nVariables) + sumGlobalStats(1:nVariables) = sums(1:nVariables) + + call mpas_timer_stop("global_stats", amGlobalStatsTimer) + + end subroutine ocn_compute_global_stats!}}} + +!*********************************************************************** +! +! routine ocn_restart_global_stats +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_restart_global_stats(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_restart_global_stats!}}} + +!*********************************************************************** +! +! routine ocn_finalize_global_stats +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_finalize_global_stats(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_finalize_global_stats!}}} + + subroutine ocn_compute_field_area_weighted_local_stats_max_level(dminfo, nVertLevels, nElements, maxLevel, areas, field, &!{{{ + localSum, localRMS, localMin, localMax, localVertSumMin, localVertSumMax) + + implicit none + + type (dm_info), intent(in) :: dminfo + integer, intent(in) :: nVertLevels, nElements + integer, dimension(nElements), intent(in) :: maxLevel + real (kind=RKIND), dimension(nElements), intent(in) :: areas + real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field + real (kind=RKIND), intent(out) :: localSum, localRMS, localMin, localMax, localVertSumMin, & + localVertSumMax + + integer :: elementIndex + real (kind=RKIND) :: colSum, colRMS, colSumAbs + + localSum = 0.0 + localRMS = 0.0 + localMin = 1.0e34 + localMax = -1.0e34 + localVertSumMin = 1.0e34 + localVertSumMax = -1.0e34 + + do elementIndex = 1, nElements + colSum = sum(field(1:maxLevel(elementIndex),elementIndex)) + localSum = localSum + areas(elementIndex) * colSum + colRMS = sum(field(1:maxLevel(elementIndex),elementIndex)**2) + localRMS = localRMS + areas(elementIndex) * colRMS + localMin = min(localMin,minval(field(1:maxLevel(elementIndex),elementIndex))) + localMax = max(localMax,maxval(field(1:maxLevel(elementIndex),elementIndex))) + localVertSumMin = min(localVertSumMin,colSum) + localVertSumMax = max(localVertSumMax,colSum) + end do + + end subroutine ocn_compute_field_area_weighted_local_stats_max_level!}}} + + subroutine ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nElements, maxLevel, areas, layerThickness, field, &!{{{ + localSum, localRMS, localMin, localMax, localVertSumMin, localVertSumMax) + + implicit none + + type (dm_info), intent(in) :: dminfo + integer, intent(in) :: nVertLevels, nElements + integer, dimension(nElements), intent(in) :: maxLevel + real (kind=RKIND), dimension(nElements), intent(in) :: areas + real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: layerThickness + real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: field + real (kind=RKIND), intent(out) :: localSum, localRMS, localMin, localMax, localVertSumMin, & + localVertSumMax + + integer :: elementIndex + real (kind=RKIND) :: thicknessWeightedColSum, thicknessWeightedColRMS, thicknessWeightedColSumAbs + real (kind=RKIND), dimension(nVertLevels, nElements) :: hTimesField + + localSum = 0.0 + localRMS = 0.0 + localMin = 1.0e34 + localMax = -1.0e34 + localVertSumMin = 1.0e34 + localVertSumMax = -1.0e34 + + do elementIndex = 1, nElements + thicknessWeightedColSum = sum(layerThickness(1:maxLevel(elementIndex),elementIndex)*field(1:maxLevel(elementIndex),elementIndex)) + localSum = localSum + areas(elementIndex) * thicknessWeightedColSum + thicknessWeightedColRMS = sum(layerThickness(1:maxLevel(elementIndex),elementIndex)*field(1:maxLevel(elementIndex),elementIndex)**2) + localRMS = localRMS + areas(elementIndex) * thicknessWeightedColRMS + localMin = min(localMin,minval(field(1:maxLevel(elementIndex),elementIndex))) + localMax = max(localMax,maxval(field(1:maxLevel(elementIndex),elementIndex))) + localVertSumMin = min(localVertSumMin,thicknessWeightedColSum) + localVertSumMax = max(localVertSumMax,thicknessWeightedColSum) + end do + + end subroutine ocn_compute_field_volume_weighted_local_stats_max_level!}}} + +end module ocn_global_stats + +! vim: foldmethod=marker diff --git a/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F b/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F new file mode 100644 index 0000000000..e74b7c517d --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F @@ -0,0 +1,568 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_zonal_mean +! +!> \brief MPAS ocean analysis core member: zonal_mean +!> \author Mark Petersen +!> \date March 2014 +!> \details +!> MPAS ocean analysis core member: zonal_mean +!> Compute zonal means of selected variables +! +!----------------------------------------------------------------------- + +module ocn_zonal_mean + + use mpas_grid_types + use mpas_timer + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_diagnostics_routines + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_setup_packages_zonal_mean, & + ocn_init_zonal_mean, & + ocn_compute_zonal_mean, & + ocn_restart_zonal_mean, & + ocn_finalize_zonal_mean + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + integer :: nZonalMeanBinsUsed + type (timer_node), pointer :: amZonalMeanTimer + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_setup_packages_zonal_mean +! +!> \brief Set up packages for MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine is intended to configure the packages for this MPAS +!> ocean analysis member +! +!----------------------------------------------------------------------- + + subroutine ocn_setup_packages_zonal_mean(configPool, packagePool, err)!{{{ + + use mpas_packages + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + logical, pointer :: amZonalMeanActive + + err = 0 + + call mpas_pool_get_package(packagePool, 'amZonalMeanActive', amZonalMeanActive) + + ! turn on package for this analysis member + amZonalMeanActive = .true. + + end subroutine ocn_setup_packages_zonal_mean!}}} + +!*********************************************************************** +! +! routine ocn_init_zonal_mean +! +!> \brief Initialize MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date March 2014 +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_zonal_mean(domain, err)!{{{ + + use mpas_packages + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: amZonalMeanPool + type (mpas_pool_type), pointer :: meshPool + + integer :: iBin + integer, pointer :: nZonalMeanBins + + real (kind=RKIND) :: binWidth + ! These are array size 1 because mpas_dmpar_min_real_array calls require arrays. + real (kind=RKIND), dimension(1) :: minBin, maxBin, minBinDomain, maxBinDomain + real (kind=RKIND), dimension(:), pointer :: binCenterZonalMean, binBoundaryZonalMean, binVariable + + integer, pointer :: config_number_zonal_mean_bins + real (kind=RKIND), pointer :: config_min_zonal_mean_bin, config_max_zonal_mean_bin + + logical, pointer :: on_a_sphere + + dminfo = domain % dminfo + + err = 0 + + minBin = 1.0e34 + maxBin = -1.0e34 + + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nZonalMeanBins', nZonalMeanBins) + call mpas_pool_get_subpool(domain % blocklist % structs, 'amZonalMean', amZonalMeanPool) + + call mpas_pool_get_config(domain % configs, 'config_number_zonal_mean_bins', config_number_zonal_mean_bins) + call mpas_pool_get_config(domain % configs, 'config_min_zonal_mean_bin', config_min_zonal_mean_bin) + call mpas_pool_get_config(domain % configs, 'config_max_zonal_mean_bin', config_max_zonal_mean_bin) + + nZonalMeanBinsUsed = min( config_number_zonal_mean_bins, nZonalMeanBins ) + + call mpas_pool_get_array(amZonalMeanPool, 'binCenterZonalMean', binCenterZonalMean) + call mpas_pool_get_array(amZonalMeanPool, 'binBoundaryZonalMean', binBoundaryZonalMean) + + ! Find min and max values of binning variable. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + ! Bin by latitude on a sphere, by yCell otherwise. + if (on_a_sphere) then + call mpas_pool_get_array(meshPool, 'latCell', binVariable) + else + call mpas_pool_get_array(meshPool, 'yCell', binVariable) + end if + + minBin = min(minBin, minval(binVariable) ) + maxBin = max(maxBin, maxval(binVariable) ) + + block => block % next + end do + + call mpas_dmpar_min_real_array(dminfo, 1, minBin, minBinDomain) + call mpas_dmpar_max_real_array(dminfo, 1, maxBin, maxBinDomain) + + ! Set up bins. + binBoundaryZonalMean = -1.0e34 + binCenterZonalMean = -1.0e34 + + ! Change min and max bin bounds to configuration settings, if applicable. + if (config_min_zonal_mean_bin > -1.0e33) then + minBinDomain(1) = config_min_zonal_mean_bin + else + ! use measured min value, but decrease slightly to include least value. + minBinDomain(1) = minBinDomain(1) - 1.0e-10 * abs(minBinDomain(1)) + end if + + if (config_max_zonal_mean_bin > -1.0e33) then + maxBinDomain(1) = config_max_zonal_mean_bin + else + ! use measured max value, but increase slightly to include max value. + maxBinDomain(1) = maxBinDomain(1) + 1.0e-10 * abs(maxBinDomain(1)) + end if + + binBoundaryZonalMean(1) = minBinDomain(1) + binWidth = (maxBinDomain(1) - minBinDomain(1)) / nZonalMeanBinsUsed + + binCenterZonalMean(1) = minBinDomain(1) + binWidth/2.0 + do iBin = 2, nZonalMeanBinsUsed + binBoundaryZonalMean(iBin) = binBoundaryZonalMean(iBin-1) + binWidth + binCenterZonalMean(iBin) = binCenterZonalMean(iBin-1) + binWidth + end do + binBoundaryZonalMean(nZonalMeanBinsUsed+1) = binBoundaryZonalMean(nZonalMeanBinsUsed) + binWidth + + end subroutine ocn_init_zonal_mean!}}} + +!*********************************************************************** +! +! routine ocn_compute_zonal_mean +! +!> \brief Compute MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date March 2014 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: amZonalMeanPool + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + + integer :: iTracer, k, iCell, kMax + integer :: iBin, iField, nZonalMeanVariables + integer, pointer :: num_tracers, nCellsSolve, nVertLevels, nZonalMeanBins + integer, dimension(:), pointer :: maxLevelCell + + real (kind=RKIND), dimension(:), pointer :: areaCell, binVariable, binBoundaryZonalMean + real (kind=RKIND), dimension(:,:), pointer :: velocityZonal, velocityMeridional + real (kind=RKIND), dimension(:,:), pointer :: velocityZonalZonalMean, velocityMeridionalZonalMean + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), allocatable :: sumZonalMean, totalSumZonalMean, normZonalMean + real (kind=RKIND), dimension(:,:,:), pointer :: tracersZonalMean + + logical, pointer :: on_a_sphere + + err = 0 + dminfo = domain % dminfo + + call mpas_timer_start("compute_zonal_mean", .false., amZonalMeanTimer) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'amZonalMean', amZonalMeanPool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + nZonalMeanVariables = num_tracers + 3 + + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nZonalMeanBins', nZonalMeanBins) + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(amZonalMeanPool, 'binBoundaryZonalMean', binBoundaryZonalMean) + + allocate(sumZonalMean(nZonalMeanVariables,nVertLevels,nZonalMeanBinsUsed), & + totalSumZonalMean(nZonalMeanVariables,nVertLevels,nZonalMeanBinsUsed), & + normZonalMean(nZonalMeanVariables,nVertLevels,nZonalMeanBins)) + + sumZonalMean = 0.0 + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + + !state => block % state % time_levs(timeLevel) % state + !mesh => block % mesh + !scratch => block % scratch + !diagnostics => block % diagnostics + + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(statePool, 'tracers', tracers,timeLevel) + call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) + + ! Bin by latitude on a sphere, by yCell otherwise. + if (on_a_sphere) then + call mpas_pool_get_array(meshPool, 'latCell', binVariable) + else + call mpas_pool_get_array(meshPool, 'yCell', binVariable) + end if + + ! note that sum is for each vertical index, which is a little wrong for z-star and very wrong for PBCs. + do iCell = 1, nCellsSolve + kMax = maxLevelCell(iCell) + + if (binVariable(iCell) .lt. binBoundaryZonalMean(1)) cycle + + do iBin = 1, nZonalMeanBinsUsed + if (binVariable(iCell) .lt. binBoundaryZonalMean(iBin+1) ) then + + do k = 1, kMax + + ! Field 1 is the total area in this bin, which can vary by level due to land. + sumZonalMean(1,k,iBin) = sumZonalMean(1,k,iBin) + areaCell(iCell) + + do iField = 1,num_tracers + sumZonalMean(iField+1,k,iBin) = sumZonalMean(iField+1,k,iBin) + tracers(iField,k,iCell)*areaCell(iCell) + enddo + + iField = num_tracers+2 + sumZonalMean(iField,k,iBin) = sumZonalMean(iField,k,iBin) + velocityZonal(k,iCell)*areaCell(iCell) + iField = iField+1 + sumZonalMean(iField,k,iBin) = sumZonalMean(iField,k,iBin) + velocityMeridional(k,iCell)*areaCell(iCell) + + end do + exit + + endif + end do + + end do + + block => block % next + end do + + ! mpi summation over all processors + call mpas_dmpar_sum_real_array(dminfo, nVertLevels*nZonalMeanBinsUsed*nZonalMeanVariables, sumZonalMean, totalSumZonalMean) + + ! normalize by area + do iBin = 1, nZonalMeanBinsUsed + do k = 1, nVertLevels + ! Check if there is any area accumulated. If so, normalize by the area. + if (totalSumZonalMean(1,k,iBin) > 1.0e-12) then + normZonalMean(:,k,iBin) = totalSumZonalMean(:,k,iBin) / totalSumZonalMean(1,k,iBin) + else + normZonalMean(:,k,iBin) = -1.0e34 + end if + end do + end do + do iBin = nZonalMeanBinsUsed + 1, nZonalMeanBins + normZonalMean(:,:,iBin) = -1.0e34 + end do + + ! Even though these variables do not include an index that is decomposed amongst + ! domain partitions, we assign them within a block loop so that all blocks have the + ! correct values for writing output. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nZonalMeanBins', nZonalMeanBins) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block % structs, 'amZonalMean', amZonalMeanPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + + call mpas_pool_get_array(amZonalMeanPool, 'tracersZonalMean', tracersZonalMean) + call mpas_pool_get_array(amZonalMeanPool, 'velocityZonalZonalMean', velocityZonalZonalMean) + call mpas_pool_get_array(amZonalMeanPool, 'velocityMeridionalZonalMean', velocityMeridionalZonalMean) + + do iBin = 1, nZonalMeanBins + do k = 1, nVertLevels + + do iField = 1, num_tracers + tracersZonalMean(iField,k,iBin) = normZonalMean(iField+1,k,iBin) + enddo + + iField = num_tracers + 2 + velocityZonalZonalMean(k,iBin) = normZonalMean(iField,k,iBin) + iField = iField+1 + velocityMeridionalZonalMean(k,iBin) = normZonalMean(iField,k,iBin) + + end do + end do + + block => block % next + end do + + deallocate(sumZonalMean,totalSumZonalMean,normZonalMean) + + call mpas_timer_stop("zonal_mean", amZonalMeanTimer) + + end subroutine ocn_compute_zonal_mean!}}} + +!*********************************************************************** +! +! routine ocn_restart_zonal_mean +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date March 2014 +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_restart_zonal_mean(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_restart_zonal_mean!}}} + +!*********************************************************************** +! +! routine ocn_finalize_zonal_mean +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date March 2014 +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_finalize_zonal_mean(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_finalize_zonal_mean!}}} + +end module ocn_zonal_mean + +! vim: foldmethod=marker diff --git a/src/core_ocean/build_options.mk b/src/core_ocean/build_options.mk new file mode 100644 index 0000000000..92c581ed0b --- /dev/null +++ b/src/core_ocean/build_options.mk @@ -0,0 +1,17 @@ +PWD=$(shell pwd) +ifeq "$(MODE)" "analysis" + EXE_NAME=ocean_analysis_model + NAMELIST_SUFFIX=ocean_analysis + FCINCLUDES += -I$(PWD)/src/core_ocean/mode_analysis -I$(PWD)/src/core_ocean/shared -I$(PWD)/src/core_ocean/analysis_members -I$(PWD)/src/core_ocean/cvmix +else ifeq "$(MODE)" "forward" + EXE_NAME=ocean_forward_model + NAMELIST_SUFFIX=ocean_forward + FCINCLUDES += -I$(PWD)/src/core_ocean/mode_forward -I$(PWD)/src/core_ocean/shared -I$(PWD)/src/core_ocean/analysis_members -I$(PWD)/src/core_ocean/cvmix +else + EXE_NAME=ocean*_model + NAMELIST_SUFFIX=ocean* +endif + +report_builds: + @echo "CORE=ocean MODE=analysis" + @echo "CORE=ocean MODE=forward" diff --git a/src/core_ocean/get_cvmix.sh b/src/core_ocean/get_cvmix.sh new file mode 100755 index 0000000000..96c50e161b --- /dev/null +++ b/src/core_ocean/get_cvmix.sh @@ -0,0 +1,103 @@ +#!/bin/bash + +## CVMix Tag for build +CVMIX_TAG=v0.60-beta + +## Subdirectory in CVMix repo to use +CVMIX_SUBDIR=src/shared + +## Available protocols for acquiring CVMix source code +CVMIX_GIT_HTTP_ADDRESS=https://github.com/CVMix/CVMix-src.git +CVMIX_GIT_SSH_ADDRESS=git@github.com:CVMix/CVMix-src.git +CVMIX_SVN_ADDRESS=https://github.com/CVMix/CVMix-src/tags +CVMIX_WEB_ADDRESS=https://github.com/CVMix/CVMix-src/archive + +GIT=`which git` +SVN=`which svn` +PROTOCOL="" + +# CVMix exists. Need to make sure it's updated if it is git. +# Otherwise, flush the directory to ensure it's updated. +if [ -d cvmix ]; then + unlink cvmix + + if [ -d .cvmix_all/.git ]; then + cd .cvmix_all + git fetch origin &> /dev/null + git checkout ${CVMIX_TAG} &> /dev/null + cd ../ + ln -sf .cvmix_all/${CVMIX_SUBDIR} cvmix + else + rm -rf .cvmix_all + fi +fi + +# CVmix Doesn't exist, need to acquire souce code +# If might have been flushed from the above if, in the case where it was svn or wget that acquired the source. +if [ ! -d cvmix ]; then + if [ -d .cvmix_all ]; then + rm -rf .cvmix_all + fi + + if [ "${GIT}" != "" ]; then + echo " ** Using git to acquire cvmix source. ** " + PROTOCOL="git https" + git clone ${CVMIX_GIT_HTTP_ADDRESS} .cvmix_all &> /dev/null + if [ -d .cvmix_all ]; then + cd .cvmix_all + git checkout ${CVMIX_TAG} &> /dev/null + cd ../ + ln -sf .cvmix_all/${CVMIX_SUBDIR} cvmix + else + git clone ${CVMIX_GIT_SSH_ADDRESS} .cvmix_all &> /dev/null + PROTOCOL="git ssh" + if [ -d .cvmix_all ]; then + cd .cvmix_all + git checkout ${CVMIX_TAG} &> /dev/null + cd ../ + ln -sf .cvmix_all/${CVMIX_SUBDIR} cvmix + fi + fi + elif [ "${SVN}" != "" ]; then + echo " ** Using svn to acquire cvmix source. ** " + PROTOCOL="svn" + svn co ${CVMIX_SVN_ADDRESS}/${CVMIX_TAG} .cvmix_all &> /dev/null + ln -sf .cvmix_all/${CVMIX_SUBDIR} cvmix + else + echo " ** Using wget to acquire cvmix source. ** " + PROTOCOL="svn" + CVMIX_ZIP_DIR=`echo ${CVMIX_TAG} | sed 's/v//g'` + CVMIX_ZIP_DIR="CVMix-src-${CVMIX_ZIP_DIR}" + if [ ! -e .${CVMIX_TAG}.zip ]; then + wget ${CVMIX_WEB_ADDRESS}/${CVMIX_TAG}.zip &> /dev/null + fi + unzip ${CVMIX_TAG}.zip &> /dev/null + mv ${CVMIX_TAG}.zip .${CVMIX_TAG}.zip + mv ${CVMIX_ZIP_DIR} .cvmix_all + ln -sf .cvmix_all/${CVMIX_SUBDIR} cvmix + fi +fi + +if [ ! -d cvmix ]; then + echo " ****************************************************** " + echo " ERROR: Build failed to acquire CVMix source." + echo "" + echo " Please ensure your proxy information is setup properly for" + echo " the protocol you use to acquire CVMix." + echo "" + echo " The automated script attempted to use: ${PROTOCOL}" + echo "" + if [ "${PROTOCOL}" == "git http" ]; then + echo " This protocol requires setting up the http.proxy git config option." + elif [ "${PROTOCOL}" == "git ssh" ]; then + echo " This protocol requires having ssh-keys setup, and ssh access to git@github.com." + echo " Please use 'ssh -vT git@github.com' to debug issues with ssh keys." + elif [ "${PROTOCOL}" == "svn" ]; then + echo " This protocol requires having svn proxys setup properly in ~/.subversion/servers." + elif [ "${PROTOCOL}" == "wget" ]; then + echo " This protocol requires having the http_proxy and https_proxy environment variables" + echo " setup properly for your shell." + fi + echo "" + echo " ****************************************************** " +fi diff --git a/src/core_ocean/mode_analysis/Makefile b/src/core_ocean/mode_analysis/Makefile new file mode 100644 index 0000000000..141fb057ec --- /dev/null +++ b/src/core_ocean/mode_analysis/Makefile @@ -0,0 +1,19 @@ +.SUFFIXES: .F .o + +OBJS = mpas_ocn_analysis_core.o + +all: $(OBJS) + +mpas_ocn_am_mpas_core.o: + +clean: + $(RM) *.o *.i *.mod *.f90 libdycore.a + +.F.o: + $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) +endif diff --git a/src/core_ocean/mode_analysis/mpas_ocn_analysis_core.F b/src/core_ocean/mode_analysis/mpas_ocn_analysis_core.F new file mode 100644 index 0000000000..0898dad746 --- /dev/null +++ b/src/core_ocean/mode_analysis/mpas_ocn_analysis_core.F @@ -0,0 +1,553 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! mpas_core +! +!> \brief Main driver for MPAS ocean analysis core in post-processing mode +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This module contains the drivers for the MPAS ocean analysis core in +!> post-processing mode. None of these routines are used in run-time mode +!> by the ocean core. +! +!----------------------------------------------------------------------- + +module mpas_core + + use mpas_framework + use mpas_timekeeping + use mpas_dmpar + use mpas_timer + use mpas_io_units + + use ocn_analysis_driver + use ocn_init + use ocn_diagnostics + use ocn_equation_of_state + use ocn_constants + use ocn_time_average + + type (MPAS_Clock_type), pointer :: clock + + character(len=*), parameter :: statsAlarmID = 'stats' + character(len=*), parameter :: coupleAlarmID = 'couple' + + type (timer_node), pointer :: globalDiagTimer, timeIntTimer, testSuiteTimer + type (timer_node), pointer :: initDiagSolveTimer + + contains + +!*********************************************************************** +! +! routine mpas_core_init +! +!> \brief Initialize MPAS-Ocean analysis post-processing core +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all initializations required to begin a +!> simulation with MPAS-Ocean +! +!----------------------------------------------------------------------- + + subroutine mpas_core_init(domain, stream_manager, startTimeStamp)!{{{ + + use mpas_grid_types + use mpas_stream_manager + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + character(len=*), intent(out) :: startTimeStamp + + type (block_type), pointer :: block + type (dm_info) :: dminfo + type (mpas_pool_type), pointer :: diagnosticsPool + + integer :: err, err_tmp + + type (MPAS_timeInterval_type) :: timeStep + + ! remove dt later + real (kind=RKIND) :: dt + character (len=StrKIND), pointer :: xtime + type (MPAS_Time_Type) :: startTime + + err = 0 + + ! + ! Set "local" clock to point to the clock contained in the domain type + ! + clock => domain % clock + + ! + ! Set startTimeStamp based on the start time of the simulation clock + ! + startTime = mpas_get_clock_time(clock, MPAS_START_TIME, err_tmp) + call mpas_get_time(startTime, dateTimeString=startTimeStamp) + err = ior(err, err_tmp) + + ! Setup ocean config pool + call ocn_constants_init(domain % configs, domain % packages) + + ! + ! Read input data for model + ! + call MPAS_stream_mgr_read(stream_manager, streamID='input', ierr=err) + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='input', ierr=err) + + dminfo = domain % dminfo + err = 0 + + ! Initialize submodules before initializing blocks. + call ocn_equation_of_state_init(err_tmp) + err = ior(err, err_tmp) + + call ocn_analysis_init(domain, err_tmp) + err = ior(err, err_tmp) + + call ocn_init_vert_coord(domain) + + call ocn_compute_max_level(domain) + + timeStep = mpas_get_clock_timestep(clock, ierr=err_tmp) + call mpas_get_timeInterval(timeStep, dt=dt) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_array(diagnosticsPool, 'xtime', xtime) + + call mpas_init_block(block, dt, err) + if(err.eq.1) then + call mpas_dmpar_abort(dminfo) + endif + + xtime = startTimeStamp + block => block % next + end do + + end subroutine mpas_core_init!}}} + +!*********************************************************************** +! +! routine mpas_simulation_clock_init +! +!> \brief Initialize timer variables +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine initializes all timer variables +! +!----------------------------------------------------------------------- + + subroutine ocn_simulation_clock_init(core_clock, configs, ierr)!{{{ + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime + type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep + character(len=StrKIND) :: restartTimeStamp + integer :: err_tmp + character (len=StrKIND), pointer :: config_start_time, config_stop_time + character (len=StrKIND), pointer :: config_run_duration + character (len=StrKIND), pointer :: config_stats_interval, config_dt, config_restart_timestamp_name + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_dt', config_dt) + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) + call mpas_pool_get_config(configs, 'config_run_duration', config_run_duration) + call mpas_pool_get_config(configs, 'config_stats_interval', config_stats_interval) + call mpas_pool_get_config(configs, 'config_restart_timestamp_name', config_restart_timestamp_name) + + if ( trim(config_start_time) == "file" ) then + open(22,file=config_restart_timestamp_name,form='formatted',status='old') + read(22,*) restartTimeStamp + close(22) + call mpas_set_time(curr_time=startTime, dateTimeString=restartTimeStamp, ierr=err_tmp) + else + call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=err_tmp) + end if + + call mpas_set_timeInterval(timeStep, timeString=config_dt, ierr=err_tmp) + if (trim(config_run_duration) /= "none") then + call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=err_tmp) + + if (trim(config_stop_time) /= "none") then + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) + if(startTime + runduration /= stopTime) then + write(stderrUnit,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.' + end if + end if + else if (trim(config_stop_time) /= "none") then + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=err_tmp) + else + write(stderrUnit,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' + ierr = 1 + end if + + if (trim(config_stats_interval) /= "none") then + call mpas_set_timeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=err_tmp) + alarmStartTime = startTime + alarmTimeStep + call mpas_add_clock_alarm(core_clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=err_tmp) + end if + + end subroutine ocn_simulation_clock_init!}}} + +!*********************************************************************** +! +! routine mpas_init_block +! +!> \brief Initialize blocks within MPAS-Ocean analysis post-processing core +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine calls all block-level initializations required to begin a +!> simulation with MPAS-Ocean +! +!----------------------------------------------------------------------- + subroutine mpas_init_block(block, dt, err)!{{{ + + use mpas_grid_types + use mpas_rbf_interpolation + use mpas_vector_operations + use mpas_vector_reconstruction + use mpas_tracer_advection_helpers + + implicit none + + type (block_type), intent(inout) :: block + real (kind=RKIND), intent(in) :: dt + integer, intent(out) :: err + + type (mpas_pool_type), pointer :: meshPool, averagePool, statePool + type (mpas_pool_type), pointer :: forcingPool, diagnosticsPool, scratchPool + integer :: i, iEdge, iCell, k + integer :: err1 + + integer, dimension(:), pointer :: nAdvCellsForEdge, maxLevelCell + integer, dimension(:), pointer :: maxLevelEdgeBot, maxLevelEdgeTop + integer, dimension(:,:), pointer :: advCellsForEdge, highOrderAdvectionMask, boundaryCell + real (kind=RKIND), dimension(:), pointer :: areaCell + real (kind=RKIND), dimension(:,:), pointer :: advCoefs, advCoefs3rd, normalTransportVelocity + real (kind=RKIND), dimension(:,:), pointer :: layerThickness + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, normalGMBolusVelocity, edgeTangentVectors + real (kind=RKIND), dimension(:,:), pointer :: velocityX, velocityY, velocityZ + real (kind=RKIND), dimension(:,:), pointer :: velocityZonal, velocityMeridional + real (kind=RKIND), dimension(:,:,:), pointer :: derivTwo + + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + integer, pointer :: nCells, nEdges, nVertices, nVertLevels + integer, pointer :: config_horiz_tracer_adv_order + logical, pointer :: config_hmix_scaleWithMesh + logical, pointer :: config_use_standardGM + real (kind=RKIND), pointer :: config_maxMeshDensity + + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block % dimensions, 'nVertices', nVertices) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'average', averagePool) + + call mpas_pool_get_array(meshPool, 'derivTwo', derivTwo) + call mpas_pool_get_array(meshPool, 'advCoefs', advCoefs) + call mpas_pool_get_array(meshPool, 'advCoefs3rd', advCoefs3rd) + call mpas_pool_get_array(meshPool, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array(meshPool, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'highOrderAdvectionMask', highOrderAdvectionMask) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) + call mpas_pool_get_array(meshPool, 'edgeTangentVectors', edgeTangentVectors) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'velocityX', velocityX) + call mpas_pool_get_array(diagnosticsPool, 'velocityY', velocityY) + call mpas_pool_get_array(diagnosticsPool, 'velocityZ', velocityZ) + call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + + call mpas_pool_get_config(block % configs, 'config_horiz_tracer_adv_order', config_horiz_tracer_adv_order) + call mpas_pool_get_config(block % configs, 'config_hmix_scaleWithMesh', config_hmix_scaleWithMesh) + call mpas_pool_get_config(block % configs, 'config_maxMeshDensity', config_maxMeshDensity) + call mpas_pool_get_config(block % configs, 'config_use_standardGM', config_use_standardGM) + call ocn_setup_sign_and_index_fields(meshPool) + call mpas_initialize_deriv_two(meshPool, derivTwo, err) + call mpas_tracer_advection_coefficients(meshPool, & + config_horiz_tracer_adv_order, derivTwo, advCoefs, & + advCoefs3rd, nAdvCellsForEdge, advCellsForEdge, & + err1, maxLevelCell, highOrderAdvectionMask, & + boundaryCell) + err = ior(err, err1) + + call ocn_time_average_init(averagePool) + + call mpas_timer_start("diagnostic solve", .false., initDiagSolveTimer) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool) + call mpas_timer_stop("diagnostic solve", initDiagSolveTimer) + + ! Compute velocity transport, used in advection terms of layerThickness and tracer tendency + normalTransportVelocity(:,:) = normalVelocity(:,:) + normalGMBolusVelocity(:,:) + + call ocn_compute_mesh_scaling(meshPool, config_hmix_scaleWithMesh, config_maxMeshDensity) + + call mpas_rbf_interp_initialize(meshPool) + call mpas_initialize_tangent_vectors(meshPool, edgeTangentVectors) + + call mpas_init_reconstruct(meshPool) + call mpas_reconstruct(meshPool, normalVelocity, & + velocityX, & + velocityY, & + velocityZ, & + velocityZonal, & + velocityMeridional & + ) + + if (config_use_standardGM) then + call ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) + end if + + ! initialize velocities and tracers on land to be zero. + areaCell(nCells+1) = -1.0e34 + + layerThickness(:, nCells+1) = 0.0 + + do iEdge=1, nEdges + normalVelocity(maxLevelEdgeTop(iEdge)+1:maxLevelEdgeBot(iEdge), iEdge) = 0.0 + + normalVelocity(maxLevelEdgeBot(iEdge)+1:nVertLevels,iEdge) = -1.0e34 + end do + + do iCell=1,nCells + tracers(:, maxLevelCell(iCell)+1:nVertLevels,iCell) = -1.0e34 + end do + + call mpas_pool_initialize_time_levels(statePool) + + end subroutine mpas_init_block!}}} + +!*********************************************************************** +! +! routine mpas_core_run +! +!> \brief Main driver for MPAS-Ocean time-stepping +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine includes the time-stepping loop, and calls timer +!> routines to write output and restart files. +! +!----------------------------------------------------------------------- + + subroutine mpas_core_run(domain, stream_manager)!{{{ + + use mpas_kind_types + use mpas_stream_manager + use mpas_grid_types + use mpas_timer + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + + integer :: itimestep + real (kind=RKIND) :: dt + type (block_type), pointer :: block_ptr + + type (MPAS_Time_Type) :: currTime + character(len=StrKIND) :: timeStamp + integer :: err, ierr + + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: forcingPool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: scratchPool + + type (MPAS_timeInterval_type) :: timeStep + character (len=StrKIND), pointer :: config_dt + logical, pointer :: config_write_output_on_startup + + call mpas_pool_get_config(ocnConfigs, 'config_dt', config_dt) + call mpas_pool_get_config(ocnConfigs, 'config_write_output_on_startup', config_write_output_on_startup) + + timeStep = mpas_get_clock_timestep(clock, ierr=ierr) + call mpas_get_timeInterval(timeStep, dt=dt) + + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) + write(stderrUnit,*) 'Initial time ', trim(timeStamp) + + ! fill in diagnostics variables + call mpas_timer_start("diagnostic solve", .false., initDiagSolveTimer) + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 1) + block_ptr => block_ptr % next + end do + call mpas_timer_stop("diagnostic solve", initDiagSolveTimer) + + if (config_write_output_on_startup) then + call ocn_analysis_compute(domain, err) + call mpas_stream_mgr_write(stream_manager, ierr=ierr) + endif + + end subroutine mpas_core_run!}}} + + subroutine mpas_core_finalize(domain, stream_manager)!{{{ + + use mpas_grid_types + use mpas_stream_manager + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + integer :: ierr + + call mpas_destroy_clock(clock, ierr) + + end subroutine mpas_core_finalize!}}} + +!*********************************************************************** +! +! routine mpas_core_setup_packages +! +!> \brief Package setup routine +!> \author Doug Jacobsen +!> \date November 2013 +!> \details +!> This routine is intended to correctly configure the packages for this MPAS +!> core. It can use any Fortran logic to properly configure packages, and it +!> can also make use of any namelist options. All variables in the model are +!> *not* allocated until after this routine is called. +! +!----------------------------------------------------------------------- + subroutine mpas_core_setup_packages(configPool, packagePool, ierr)!{{{ + + use mpas_packages + + implicit none + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + integer, intent(out) :: ierr + + integer :: err_tmp + + ierr = 0 + + call ocn_analysis_setup_packages(configPool, packagePool, err_tmp) + ierr = ior(ierr, err_tmp) + + end subroutine mpas_core_setup_packages!}}} + + !*********************************************************************** + ! + ! routine mpas_core_setup_clock + ! + !> \brief Pacakge setup routine + !> \author Michael Duda + !> \date 6 August 2014 + !> \details + !> The purpose of this routine is to allow the core to set up a simulation + !> clock that will be used by the I/O subsystem for timing reads and writes + !> of I/O streams. + !> This routine is called from the superstructure after the framework + !> has been initialized but before any fields have been allocated and + !> initial fields have been read from input files. However, all namelist + !> options are available. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_setup_clock(core_clock, configs, ierr)!{{{ + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + call ocn_simulation_clock_init(core_clock, configs, ierr) + + end subroutine mpas_core_setup_clock!}}} + + !*********************************************************************** + ! + ! routine mpas_core_get_mesh_stream + ! + !> \brief Returns the name of the stream containing mesh information + !> \author Michael Duda + !> \date 8 August 2014 + !> \details + !> This routine returns the name of the I/O stream containing dimensions, + !> attributes, and mesh fields needed by the framework bootstrapping + !> routine. At the time this routine is called, only namelist options + !> are available. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_get_mesh_stream(configs, stream, ierr)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: configs + character(len=*), intent(out) :: stream + integer, intent(out) :: ierr + + logical, pointer :: config_do_restart + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) + + if (.not. associated(config_do_restart)) then + ierr = 1 + else if (config_do_restart) then + write(stream,'(a)') 'restart' + else + write(stream,'(a)') 'input' + end if + + end subroutine mpas_core_get_mesh_stream!}}} + +end module mpas_core + +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_forward/Makefile b/src/core_ocean/mode_forward/Makefile new file mode 100644 index 0000000000..f380306b19 --- /dev/null +++ b/src/core_ocean/mode_forward/Makefile @@ -0,0 +1,32 @@ +.SUFFIXES: .F .o + +OBJS = mpas_ocn_mpas_core.o \ + mpas_ocn_time_integration.o \ + mpas_ocn_time_integration_rk4.o \ + mpas_ocn_time_integration_split.o + +all: core_ocean + +core_ocean: $(OBJS) + +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_split.o: + +mpas_ocn_mpas_core.o: mpas_ocn_time_integration.o \ + mpas_ocn_time_integration_rk4.o \ + mpas_ocn_time_integration_split.o + +clean: + $(RM) *.o *.mod *.f90 libdycore.a + +.F.o: + $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) +endif diff --git a/src/core_ocean/mode_forward/mpas_ocn_mpas_core.F b/src/core_ocean/mode_forward/mpas_ocn_mpas_core.F new file mode 100644 index 0000000000..72f638c28d --- /dev/null +++ b/src/core_ocean/mode_forward/mpas_ocn_mpas_core.F @@ -0,0 +1,1013 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! mpas_core +! +!> \brief Main driver for MPAS ocean core +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This module contains initialization and timestep drivers for +!> the MPAS ocean core. +! +!----------------------------------------------------------------------- + +module mpas_core + + use mpas_framework + use mpas_timekeeping + use mpas_dmpar + use mpas_timer + use mpas_io_units + + use ocn_analysis_driver + use ocn_init + + use ocn_global_diagnostics + use ocn_time_integration + use ocn_tendency + use ocn_diagnostics + use ocn_test + + use ocn_thick_hadv + use ocn_thick_vadv + use ocn_thick_ale + use ocn_thick_surface_flux + + use ocn_vel_pressure_grad + use ocn_vel_vadv + use ocn_vel_hmix + use ocn_vel_forcing + use ocn_vel_coriolis + + use ocn_tracer_hmix + use ocn_tracer_surface_flux + use ocn_tracer_short_wave_absorption + use ocn_tracer_nonlocalflux + use ocn_gm + + use ocn_high_freq_thickness_hmix_del2 + + use ocn_equation_of_state + + use ocn_vmix + + use ocn_time_average + + use ocn_forcing + use ocn_sea_ice + + use ocn_constants + + type (MPAS_Clock_type), pointer :: clock + + character (len=*), parameter :: statsAlarmID = 'stats' + character (len=*), parameter :: coupleAlarmID = 'coupling' + + type (timer_node), pointer :: globalDiagTimer, timeIntTimer, testSuiteTimer + type (timer_node), pointer :: initDiagSolveTimer + + contains + +!*********************************************************************** +! +! routine mpas_core_init +! +!> \brief Initialize MPAS-Ocean core +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine calls all initializations required to begin a +!> simulation with MPAS-Ocean +! +!----------------------------------------------------------------------- + + subroutine mpas_core_init(domain, stream_manager, startTimeStamp)!{{{ + + use mpas_grid_types + use mpas_stream_manager + use ocn_tracer_advection + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + character(len=*), intent(out) :: startTimeStamp + + real (kind=RKIND) :: dt + type (block_type), pointer :: block + type (dm_info) :: dminfo + + integer :: err, err_tmp + integer, pointer :: nVertLevels + real (kind=RKIND) :: maxDensity, maxDensity_global + real (kind=RKIND), dimension(:), pointer :: meshDensity + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: diagnosticsPool + + character (len=StrKIND), pointer :: xtime + type (MPAS_Time_Type) :: startTime + type (MPAS_TimeInterval_type) :: timeStep + + logical, pointer :: config_do_restart, config_filter_btr_mode, config_conduct_tests + logical, pointer :: config_write_stats_on_startup + character (len=StrKIND), pointer :: config_vert_coord_movement, config_pressure_gradient_type + real (kind=RKIND), pointer :: config_maxMeshDensity + + err = 0 + + ! + ! Set "local" clock to point to the clock contained in the domain type + ! + clock => domain % clock + + ! + ! Set startTimeStamp based on the start time of the simulation clock + ! + startTime = mpas_get_clock_time(clock, MPAS_START_TIME, err_tmp) + call mpas_get_time(startTime, dateTimeString=startTimeStamp) + err = ior(err, err_tmp) + + ! Setup ocean config pool + call ocn_constants_init(domain % configs, domain % packages) + + dminfo = domain % dminfo + + call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(domain % configs, 'config_vert_coord_movement', config_vert_coord_movement) + call mpas_pool_get_config(domain % configs, 'config_pressure_gradient_type', config_pressure_gradient_type) + call mpas_pool_get_config(domain % configs, 'config_filter_btr_mode', config_filter_btr_mode) + call mpas_pool_get_config(domain % configs, 'config_maxMeshDensity', config_maxMeshDensity) + call mpas_pool_get_config(domain % configs, 'config_conduct_tests', config_conduct_tests) + call mpas_pool_get_config(domain % configs, 'config_write_stats_on_startup', config_write_stats_on_startup) + + ! + ! Read input data for model + ! + if ( config_do_restart ) then + call MPAS_stream_mgr_read(stream_manager, streamID='restart', ierr=err) + else + call MPAS_stream_mgr_read(stream_manager, streamID='input', ierr=err) + end if + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='input', ierr=err) + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='restart', ierr=err) + + ! 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_thick_surface_flux_init(err_tmp) + err = ior(err, err_tmp) + call ocn_thick_ale_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) + err = ior(err, err_tmp) + call ocn_vel_forcing_init(err_tmp) + err = ior(err, err_tmp) + + call ocn_tracer_hmix_init(err_tmp) + err = ior(err, err_tmp) + call ocn_tracer_surface_flux_init(err_tmp) + err = ior(err, err_tmp) + call ocn_tracer_advection_init(err_tmp) + err = ior(err,err_tmp) + call ocn_tracer_short_wave_absorption_init(err_tmp) + err = ior(err,err_tmp) + call ocn_gm_init(err_tmp) + err = ior(err,err_tmp) + call ocn_tracer_nonlocalflux_init(err_tmp) + err = ior(err,err_tmp) + + call ocn_vmix_init(domain, err_tmp) + err = ior(err, err_tmp) + + call ocn_equation_of_state_init(err_tmp) + err = ior(err, err_tmp) + + call ocn_tendency_init(err_tmp) + err = ior(err,err_tmp) + call ocn_diagnostics_init(err_tmp) + err = ior(err,err_tmp) + + call ocn_forcing_init(err_tmp) + err = ior(err,err_tmp) + + call ocn_high_freq_thickness_hmix_del2_init(err_tmp) + err = ior(err,err_tmp) + + call ocn_global_diagnostics_init(dminfo,err_tmp) + err = ior(err, err_tmp) + + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevels', nVertLevels) + call ocn_sea_ice_init(nVertLevels, err_tmp) + err = ior(err, err_tmp) + + call ocn_analysis_init(domain, err_tmp) + err = ior(err, err_tmp) + + call mpas_timer_init(domain) + + if(err.eq.1) then + call mpas_dmpar_abort(dminfo) + endif + + call ocn_init_vert_coord(domain) + + call ocn_compute_max_level(domain) + + if (.not.config_do_restart) call ocn_init_split_timestep(domain) + + write (stdoutUnit,'(a,a)') ' Vertical coordinate movement is: ',trim(config_vert_coord_movement) + + if (config_vert_coord_movement.ne.'fixed'.and. & + config_vert_coord_movement.ne.'uniform_stretching'.and. & + config_vert_coord_movement.ne.'impermeable_interfaces'.and. & + config_vert_coord_movement.ne.'user_specified') then + write (stderrUnit,*) ' Incorrect choice of config_vert_coord_movement.' + call mpas_dmpar_abort(dminfo) + endif + + if(config_vert_coord_movement .ne. 'impermeable_interfaces' .and. config_pressure_gradient_type .eq. 'MontgomeryPotential') then + write (stderrUnit,*) ' 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_coord_movement.ne.'fixed')then + write (stderrUnit,*) 'filter_btr_mode has only been tested with'// & + ' config_vert_coord_movement=fixed.' + call mpas_dmpar_abort(dminfo) + endif + + ! find the maximum value of the meshDensity + if (config_maxMeshDensity < 0.0) then + maxDensity=-1 + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_array(meshPool, 'meshDensity', meshDensity) + maxDensity = max(maxDensity, maxval(meshDensity)) + block => block % next + end do + call mpas_dmpar_max_real(domain % dminfo, maxDensity, maxDensity_global) + config_maxMeshDensity = maxDensity_global + endif + + ! + ! Initialize core + ! + timeStep = mpas_get_clock_timestep(clock, ierr=err) + call mpas_get_timeInterval(timeStep, dt=dt) + + block => domain % blocklist + do while (associated(block)) + call mpas_init_block(block, dt, err) + if(err.eq.1) then + call mpas_dmpar_abort(dminfo) + endif + + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_array(diagnosticsPool, 'xtime', xtime) + xtime = startTimeStamp + block => block % next + end do + + if (config_conduct_tests) then + call mpas_timer_start("test suite", .false., testSuiteTimer) + call ocn_test_suite(domain,err) + call mpas_timer_stop("test suite", testSuiteTimer) + endif + + 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) + endif + + end subroutine mpas_core_init!}}} + +!*********************************************************************** +! +! routine mpas_simulation_clock_init +! +!> \brief Initialize timer variables +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine initializes all timer variables +! +!----------------------------------------------------------------------- + + subroutine ocn_simulation_clock_init(core_clock, configs, ierr)!{{{ + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime + type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep + character(len=StrKIND) :: restartTimeStamp + character(len=StrKIND), pointer :: config_start_time, config_stop_time, config_run_duration + character(len=StrKIND), pointer :: config_stats_interval, config_dt, config_restart_timestamp_name + integer :: err_tmp + + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_dt', config_dt) + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) + call mpas_pool_get_config(configs, 'config_run_duration', config_run_duration) + call mpas_pool_get_config(configs, 'config_stats_interval', config_stats_interval) + call mpas_pool_get_config(configs, 'config_restart_timestamp_name', config_restart_timestamp_name) + + if ( trim(config_start_time) == "file" ) then + open(22,file=config_restart_timestamp_name,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=err_tmp) + end if + + call mpas_set_timeInterval(timeStep, timeString=config_dt, ierr=err_tmp) + if (trim(config_run_duration) /= "none") then + call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=err_tmp) + + if (trim(config_stop_time) /= "none") then + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) + if(startTime + runduration /= stopTime) then + write(stderrUnit,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.' + end if + end if + else if (trim(config_stop_time) /= "none") then + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=err_tmp) + else + write(stderrUnit,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' + ierr = 1 + end if + + if (trim(config_stats_interval) /= "none") then + call mpas_set_timeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=err_tmp) + alarmStartTime = startTime + alarmTimeStep + call mpas_add_clock_alarm(core_clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=err_tmp) + end if + + end subroutine ocn_simulation_clock_init!}}} + +!*********************************************************************** +! +! routine mpas_init_block +! +!> \brief Initialize blocks within MPAS-Ocean core +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine calls all block-level initializations required to begin a +!> simulation with MPAS-Ocean +! +!----------------------------------------------------------------------- + + subroutine mpas_init_block(block, dt, err)!{{{ + + use mpas_grid_types + use mpas_rbf_interpolation + use mpas_vector_operations + use mpas_vector_reconstruction + use mpas_tracer_advection_helpers + + implicit none + + type (block_type), intent(inout) :: block + real (kind=RKIND), intent(in) :: dt + integer, intent(out) :: err + + type (mpas_pool_type), pointer :: meshPool, averagePool, statePool + type (mpas_pool_type), pointer :: forcingPool, diagnosticsPool, scratchPool + integer :: i, iEdge, iCell, k + integer :: err1 + + integer, dimension(:), pointer :: nAdvCellsForEdge, maxLevelCell + integer, dimension(:), pointer :: maxLevelEdgeBot, maxLevelEdgeTop + integer, dimension(:,:), pointer :: advCellsForEdge, highOrderAdvectionMask, boundaryCell + real (kind=RKIND), dimension(:), pointer :: areaCell, boundaryLayerDepth + real (kind=RKIND), dimension(:,:), pointer :: advCoefs, advCoefs3rd, normalTransportVelocity + real (kind=RKIND), dimension(:,:), pointer :: layerThickness + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, normalGMBolusVelocity, edgeTangentVectors + real (kind=RKIND), dimension(:,:), pointer :: velocityX, velocityY, velocityZ + real (kind=RKIND), dimension(:,:), pointer :: velocityZonal, velocityMeridional + real (kind=RKIND), dimension(:,:,:), pointer :: derivTwo + + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + integer, pointer :: nCells, nEdges, nVertices, nVertLevels + integer, pointer :: config_horiz_tracer_adv_order + logical, pointer :: config_hmix_scaleWithMesh, config_do_restart + logical, pointer :: config_use_standardGM + real (kind=RKIND), pointer :: config_maxMeshDensity + + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block % dimensions, 'nVertices', nVertices) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'average', averagePool) + + call mpas_pool_get_array(meshPool, 'derivTwo', derivTwo) + call mpas_pool_get_array(meshPool, 'advCoefs', advCoefs) + call mpas_pool_get_array(meshPool, 'advCoefs3rd', advCoefs3rd) + call mpas_pool_get_array(meshPool, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array(meshPool, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'highOrderAdvectionMask', highOrderAdvectionMask) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) + call mpas_pool_get_array(meshPool, 'edgeTangentVectors', edgeTangentVectors) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'velocityX', velocityX) + call mpas_pool_get_array(diagnosticsPool, 'velocityY', velocityY) + call mpas_pool_get_array(diagnosticsPool, 'velocityZ', velocityZ) + call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) + call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + + call mpas_pool_get_config(block % configs, 'config_horiz_tracer_adv_order', config_horiz_tracer_adv_order) + call mpas_pool_get_config(block % configs, 'config_hmix_scaleWithMesh', config_hmix_scaleWithMesh) + call mpas_pool_get_config(block % configs, 'config_maxMeshDensity', config_maxMeshDensity) + call mpas_pool_get_config(block % configs, 'config_use_standardGM', config_use_standardGM) + call mpas_pool_get_config(block % configs, 'config_do_restart', config_do_restart) + + call ocn_setup_sign_and_index_fields(meshPool) + call mpas_initialize_deriv_two(meshPool, derivTwo, err) + call mpas_tracer_advection_coefficients(meshPool, & + config_horiz_tracer_adv_order, derivTwo, advCoefs, & + advCoefs3rd, nAdvCellsForEdge, advCellsForEdge, & + err1, maxLevelCell, highOrderAdvectionMask, & + boundaryCell) + err = ior(err, err1) + + call ocn_time_average_init(averagePool) + + if (.not. config_do_restart) then + do iCell=1,nCells + boundaryLayerDepth(iCell) = layerThickness(1, iCell) * 0.5 + end do + end if + + call mpas_timer_start("diagnostic solve", .false., initDiagSolveTimer) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool) + call mpas_timer_stop("diagnostic solve", initDiagSolveTimer) + + ! initialize velocities and tracers on land to be zero. + areaCell(nCells+1) = -1.0e34 + + layerThickness(:, nCells+1) = 0.0 + + do iEdge=1, nEdges + normalVelocity(maxLevelEdgeTop(iEdge)+1:maxLevelEdgeBot(iEdge), iEdge) = 0.0 + + normalVelocity(maxLevelEdgeBot(iEdge)+1:nVertLevels,iEdge) = -1.0e34 + end do + + do iCell=1,nCells + tracers(:, maxLevelCell(iCell)+1:nVertLevels,iCell) = -1.0e34 + end do + + ! ------------------------------------------------------------------ + ! Accumulating various parametrizations of the transport velocity + ! ------------------------------------------------------------------ + normalTransportVelocity(:,:) = normalVelocity(:,:) + + ! Compute normalGMBolusVelocity, relativeSlope and RediDiffVertCoef if respective flags are turned on + if (config_use_standardGM) then + call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) + end if + + if (config_use_standardGM) then + normalTransportVelocity(:,:) = normalTransportVelocity(:,:) + normalGMBolusVelocity(:,:) + end if + ! ------------------------------------------------------------------ + ! End: Accumulating various parametrizations of the transport velocity + ! ------------------------------------------------------------------ + + call ocn_compute_mesh_scaling(meshPool, config_hmix_scaleWithMesh, config_maxMeshDensity) + + call mpas_rbf_interp_initialize(meshPool) + call mpas_initialize_tangent_vectors(meshPool, edgeTangentVectors) + + call mpas_init_reconstruct(meshPool) + + call mpas_reconstruct(meshPool, normalVelocity, & + velocityX, & + velocityY, & + velocityZ, & + velocityZonal, & + velocityMeridional & + ) + + if (config_use_standardGM) then + call ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) + end if + + call mpas_pool_initialize_time_levels(statePool) + + end subroutine mpas_init_block!}}} + +!*********************************************************************** +! +! routine mpas_core_run +! +!> \brief Main driver for MPAS-Ocean time-stepping +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine includes the time-stepping loop, and calls timer +!> routines to write output and restart files. +! +!----------------------------------------------------------------------- + + subroutine mpas_core_run(domain, stream_manager)!{{{ + + use mpas_kind_types + use mpas_grid_types + use mpas_stream_manager + use mpas_timer + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + + integer :: itimestep, err + real (kind=RKIND) :: dt + type (block_type), pointer :: block_ptr + + type (MPAS_Time_Type) :: currTime + character(len=StrKIND) :: timeStamp + integer :: ierr + + type (mpas_pool_type), pointer :: averagePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: forcingPool + + type (MPAS_timeInterval_type) :: timeStep + character(len=StrKIND), pointer :: config_restart_timestamp_name + logical, pointer :: config_write_output_on_startup + + call mpas_pool_get_config(domain % configs, 'config_write_output_on_startup', config_write_output_on_startup) + call mpas_pool_get_config(domain % configs, 'config_restart_timestamp_name', config_restart_timestamp_name) + + ! Eventually, dt should be domain specific + timeStep = mpas_get_clock_timestep(clock, ierr=ierr) + call mpas_get_timeInterval(timeStep, dt=dt) + + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) + write(stderrUnit,*) 'Initial time ', trim(timeStamp) + + call ocn_analysis_compute_startup(domain, stream_manager, err) + + if (config_write_output_on_startup) then + call mpas_stream_mgr_write(stream_manager, 'output', forceWriteNow=.true., ierr=ierr) + endif + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'average', averagePool) + call ocn_time_average_init(averagePool) + block_ptr => block_ptr % next + end do + + ! During integration, time level 1 stores the model state at the beginning of the + ! time step, and time level 2 stores the state advanced dt in time by timestep(...) + itimestep = 0 + do while (.not. mpas_is_clock_stop_time(clock)) + call mpas_stream_mgr_read(stream_manager, ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_INPUT, ierr=ierr) + + itimestep = itimestep + 1 + call mpas_advance_clock(clock) + + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) + write(stderrUnit,*) 'Doing timestep ', trim(timeStamp) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + call ocn_forcing_build_arrays(meshPool, statePool, forcingPool, ierr, 1) + call ocn_forcing_build_transmission_array(meshPool, statePool, forcingpool, ierr, 1) + block_ptr => block_ptr % next + end do + + call mpas_timer_start("time integration", .false., timeIntTimer) + call mpas_timestep(domain, itimestep, dt, timeStamp) + call mpas_timer_stop("time integration", timeIntTimer) + + ! Move time level 2 fields back into time level 1 for next time step + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_shift_time_levels(statePool) + block_ptr => block_ptr % next + end do + + call ocn_analysis_compute_w_alarms(stream_manager, domain, err) + call ocn_analysis_write(stream_manager, err) + + call mpas_stream_mgr_write(stream_manager, streamID='output', ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='output', ierr=ierr) + + if ( mpas_stream_mgr_ringing_alarms(stream_manager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr) ) then + open(22, file=config_restart_timestamp_name, form='formatted', status='replace') + write(22, *) trim(timeStamp) + close(22) + end if + + call mpas_stream_mgr_write(stream_manager, streamID='restart', ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='restart', ierr=ierr) + + call mpas_stream_mgr_write(stream_manager, ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) + end do + + end subroutine mpas_core_run!}}} + +!*********************************************************************** +! +! routine mpas_core_run +! +!> \brief Sub-driver for MPAS-Ocean time-stepping +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine calls the time integration routine within a time-stepping loop. +! +!----------------------------------------------------------------------- + + subroutine mpas_timestep(domain, itimestep, dt, timeStamp)!{{{ + + use mpas_kind_types + use mpas_grid_types + + implicit none + + type (domain_type), intent(inout) :: domain + integer, intent(in) :: itimestep + real (kind=RKIND), intent(in) :: dt + character(len=*), intent(in) :: timeStamp + + type (block_type), pointer :: block_ptr + integer :: ierr + + 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 + + !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) + +! block_ptr => domain % blocklist +! if (associated(block_ptr % next)) then +! write(stderrUnit,*) '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, 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_split_timestep(domain)!{{{ + ! Initialize splitting variables + + use mpas_grid_types + use mpas_configure + + implicit none + + type (domain_type), intent(inout) :: domain + + integer :: i, iCell, iEdge, iVertex, k + type (block_type), pointer :: block + + type (mpas_pool_type), pointer :: statePool, meshPool + + integer :: iTracer, cell, cell1, cell2 + integer, dimension(:), pointer :: maxLevelEdgeTop + integer, dimension(:,:), pointer :: cellsOnEdge + real (kind=RKIND) :: normalThicknessFluxSum, layerThicknessSum, layerThicknessEdge1 + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, normalBarotropicVelocity + + real (kind=RKIND), dimension(:,:), pointer :: layerThickness + real (kind=RKIND), dimension(:,:), pointer :: normalBaroclinicVelocity, normalVelocity + integer, pointer :: nVertLevels, nCells, nEdges + character (len=StrKIND), pointer :: config_time_integrator + logical, pointer :: config_filter_btr_mode + + ! Initialize z-level mesh variables from h, read in from input file. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_config(block % configs, 'config_time_integrator', config_time_integrator) + call mpas_pool_get_config(block % configs, 'config_filter_btr_mode', config_filter_btr_mode) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, 1) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocity, 1) + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocity, 1) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + + ! Compute barotropic velocity at first timestep + ! This is only done upon start-up. + if (trim(config_time_integrator) == 'unsplit_explicit') then + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocity) + normalBarotropicVelocity(:) = 0.0 + + normalBaroclinicVelocity(:,:) = normalVelocity(:,:) + + elseif (trim(config_time_integrator) == 'split_explicit') then + + if (config_filter_btr_mode) then + do iCell = 1, nCells + layerThickness(1,iCell) = refBottomDepth(1) + enddo + endif + + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! normalBarotropicVelocity = sum(u)/sum(h) on each column + ! ocn_diagnostic_solve has not yet been called, so compute hEdge + ! just for this edge. + + ! thicknessSum is initialized outside the loop because on land boundaries + ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a + ! nonzero value to avoid a NaN. + layerThicknessEdge1 = 0.5*( layerThickness(1,cell1) + layerThickness(1,cell2) ) + normalThicknessFluxSum = layerThicknessEdge1 * normalVelocity(1,iEdge) + layerThicknessSum = layerThicknessEdge1 + + do k=2, maxLevelEdgeTop(iEdge) + ! ocn_diagnostic_solve has not yet been called, so compute hEdge + ! just for this edge. + layerThicknessEdge1 = 0.5*( layerThickness(k,cell1) + layerThickness(k,cell2) ) + + normalThicknessFluxSum = normalThicknessFluxSum & + + layerThicknessEdge1 * normalVelocity(k,iEdge) + layerThicknessSum = layerThicknessSum + layerThicknessEdge1 + + enddo + normalBarotropicVelocity(iEdge) = normalThicknessFluxSum / layerThicknessSum + + ! normalBaroclinicVelocity(k,iEdge) = normalVelocity(k,iEdge) - normalBarotropicVelocity(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) + normalBaroclinicVelocity(k,iEdge) = normalVelocity(k,iEdge) - normalBarotropicVelocity(iEdge) + enddo + + ! normalBaroclinicVelocity=0, normalVelocity=0 on land cells + do k = maxLevelEdgeTop(iEdge)+1, nVertLevels + normalBaroclinicVelocity(k,iEdge) = 0.0 + normalVelocity(k,iEdge) = 0.0 + enddo + enddo + + if (config_filter_btr_mode) then + ! filter normalBarotropicVelocity out of initial condition + normalVelocity(:,:) = normalBaroclinicVelocity(:,:) + + normalBarotropicVelocity(:) = 0.0 + endif + + endif + + block => block % next + end do + + end subroutine ocn_init_split_timestep!}}} + + subroutine mpas_core_finalize(domain, stream_manager)!{{{ + + use mpas_grid_types + use mpas_stream_manager + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + integer :: ierr + + call ocn_analysis_finalize(domain, ierr) + + call mpas_destroy_clock(clock, ierr) + + end subroutine mpas_core_finalize!}}} + +!*********************************************************************** +! +! routine mpas_core_setup_packages +! +!> \brief Package setup routine +!> \author Doug Jacobsen +!> \date September 2011 +!> \details +!> This routine is intended to correctly configure the packages for this MPAS +!> core. It can use any Fortran logic to properly configure packages, and it +!> can also make use of any namelist options. All variables in the model are +!> *not* allocated until after this routine is called. +! +!----------------------------------------------------------------------- + subroutine mpas_core_setup_packages(configPool, packagePool, ierr)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + integer, intent(out) :: ierr + + integer :: err_tmp + + logical, pointer :: thicknessFilterActive + logical, pointer :: splitTimeIntegratorActive + logical, pointer :: surfaceRestoringActive + logical, pointer :: bulkForcingActive + logical, pointer :: frazilIceActive + logical, pointer :: inSituEOSActive + + logical, pointer :: config_use_freq_filtered_thickness + logical, pointer :: config_frazil_ice_formation + character (len=StrKIND), pointer :: config_time_integrator, config_forcing_type, config_pressure_gradient_type + + call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) + call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) + call mpas_pool_get_package(packagePool, 'surfaceRestoringActive', surfaceRestoringActive) + call mpas_pool_get_package(packagePool, 'bulkForcingActive', bulkForcingActive) + call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) + call mpas_pool_get_package(packagePool, 'inSituEOSActive', inSituEOSActive) + + call mpas_pool_get_config(configPool, 'config_use_freq_filtered_thickness', config_use_freq_filtered_thickness) + call mpas_pool_get_config(configPool, 'config_time_integrator', config_time_integrator) + call mpas_pool_get_config(configPool, 'config_forcing_type', config_forcing_type) + call mpas_pool_get_config(configPool, 'config_frazil_ice_formation', config_frazil_ice_formation) + call mpas_pool_get_config(configPool, 'config_pressure_gradient_type', config_pressure_gradient_type) + + ierr = 0 + + if (config_use_freq_filtered_thickness) then + thicknessFilterActive = .true. + end if + + if (config_time_integrator == trim('split_explicit') & + .or. config_time_integrator == trim('unsplit_explicit') ) then + + splitTimeIntegratorActive = .true. + end if + + if (config_forcing_type == trim('restoring')) then + surfaceRestoringActive = .true. + else if (config_forcing_type == trim('bulk')) then + bulkForcingActive = .true. + end if + + if (config_frazil_ice_formation) then + frazilIceActive = .true. + end if + + if (config_pressure_gradient_type.eq.'common_level_eos') then + inSituEOSActive = .true. + end if + + call ocn_analysis_setup_packages(configPool, packagePool, err_tmp) + ierr = ior(ierr, err_tmp) + + end subroutine mpas_core_setup_packages!}}} + +!*********************************************************************** +! +! routine mpas_core_setup_clock +! +!> \brief Pacakge setup routine +!> \author Michael Duda +!> \date 6 August 2014 +!> \details +!> The purpose of this routine is to allow the core to set up a simulation +!> clock that will be used by the I/O subsystem for timing reads and writes +!> of I/O streams. +!> This routine is called from the superstructure after the framework +!> has been initialized but before any fields have been allocated and +!> initial fields have been read from input files. However, all namelist +!> options are available. +! +!----------------------------------------------------------------------- + subroutine mpas_core_setup_clock(core_clock, configs, ierr)!{{{ + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + call ocn_simulation_clock_init(core_clock, configs, ierr) + + end subroutine mpas_core_setup_clock!}}} + +!*********************************************************************** +! +! routine mpas_core_get_mesh_stream +! +!> \brief Returns the name of the stream containing mesh information +!> \author Michael Duda +!> \date 8 August 2014 +!> \details +!> This routine returns the name of the I/O stream containing dimensions, +!> attributes, and mesh fields needed by the framework bootstrapping +!> routine. At the time this routine is called, only namelist options +!> are available. +! +!----------------------------------------------------------------------- + subroutine mpas_core_get_mesh_stream(configs, stream, ierr)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: configs + character(len=*), intent(out) :: stream + integer, intent(out) :: ierr + + logical, pointer :: config_do_restart + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) + + if (.not. associated(config_do_restart)) then + ierr = 1 + else if (config_do_restart) then + write(stream,'(a)') 'restart' + else + write(stream,'(a)') 'input' + end if + + end subroutine mpas_core_get_mesh_stream!}}} + +end module mpas_core + +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_time_integration.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration.F similarity index 85% rename from src/core_ocean/mpas_ocn_time_integration.F rename to src/core_ocean/mode_forward/mpas_ocn_time_integration.F index 65c25217c5..6c16ab7af2 100644 --- a/src/core_ocean/mpas_ocn_time_integration.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration.F @@ -21,7 +21,6 @@ module ocn_time_integration use mpas_grid_types - use mpas_configure use mpas_constants use mpas_dmpar use mpas_vector_reconstruction @@ -29,6 +28,7 @@ module ocn_time_integration use mpas_timer use mpas_io_units + use ocn_constants use ocn_time_integration_rk4 use ocn_time_integration_split @@ -96,6 +96,12 @@ subroutine ocn_timestep(domain, dt, timeStamp)!{{{ type (dm_info) :: dminfo type (block_type), pointer :: block + type (mpas_pool_type), pointer :: diagnosticsPool, statePool + + character (len=StrKIND), pointer :: xtime + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity + + if (rk4On) then call ocn_time_integrator_rk4(domain, dt) elseif (splitOn) then @@ -104,10 +110,15 @@ subroutine ocn_timestep(domain, dt, timeStamp)!{{{ block => domain % blocklist do while (associated(block)) -! block % state % time_levs(2) % state % xtime % scalar = timeStamp - block % diagnostics % xtime % scalar = timeStamp + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, 2) + call mpas_pool_get_array(diagnosticsPool, 'xtime', xtime) - nanCheck = sum(block % state % time_levs(2) % state % normalVelocity % array) + xtime = timeStamp + + nanCheck = sum(normalVelocity) if (nanCheck /= nanCheck) then write(stderrUnit,*) 'Abort: NaN detected' @@ -123,8 +134,12 @@ subroutine ocn_timestep_init(err)!{{{ integer, intent(out) :: err + character (len=StrKIND), pointer :: config_time_integrator + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_time_integrator', config_time_integrator) + rk4On = .false. splitOn = .false. diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F new file mode 100644 index 0000000000..fd2321dcf4 --- /dev/null +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -0,0 +1,783 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_time_integration_rk4 +! +!> \brief MPAS ocean RK4 Time integration scheme +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date September 2011 +!> \details +!> This module contains the RK4 time integration routine. +! +!----------------------------------------------------------------------- + +module ocn_time_integration_rk4 + + use mpas_grid_types + use mpas_constants + use mpas_dmpar + use mpas_vector_reconstruction + use mpas_spline_interpolation + use mpas_timer + + use ocn_constants + use ocn_tendency + use ocn_diagnostics + use ocn_gm + + use ocn_equation_of_state + use ocn_vmix + use ocn_time_average + use ocn_time_average_coupled + use ocn_sea_ice + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_time_integrator_rk4 + + contains + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_time_integrator_rk4 +! +!> \brief MPAS ocean RK4 Time integration scheme +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine integrates one timestep (dt) using an RK4 time integrator. +! +!----------------------------------------------------------------------- + + subroutine ocn_time_integrator_rk4(domain, dt)!{{{ + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Advance model state forward in time by the specified time step using + ! 4th order Runge-Kutta + ! + ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:)) + ! plus mesh meta-data + ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains + ! model state advanced forward in time by dt seconds + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + implicit none + + type (domain_type), intent(inout) :: domain !< Input/Output: domain information + real (kind=RKIND), intent(in) :: dt !< Input: timestep + + integer :: iCell, k, i, err + type (block_type), pointer :: block + + type (mpas_pool_type), pointer :: tendPool + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: provisStatePool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: verticalMeshPool + type (mpas_pool_type), pointer :: forcingPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: averagePool + + integer :: rk_step + + type (mpas_pool_type), pointer :: nextProvisPool, prevProvisPool + + real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights + + real (kind=RKIND) :: coef + real (kind=RKIND), dimension(:,:), pointer :: & + vertViscTopOfEdge, vertDiffTopOfCell + real (kind=RKIND), dimension(:), allocatable:: A,C,uTemp + real (kind=RKIND), dimension(:,:), allocatable:: tracersTemp + + ! Dimensions + integer, pointer :: nCells, nEdges, nVertLevels, num_tracers + + ! Config options + logical, pointer :: config_prescribe_velocity, config_prescribe_thickness + logical, pointer :: config_filter_btr_mode, config_use_freq_filtered_thickness + logical, pointer :: config_use_standardGM + logical, pointer :: config_use_cvmix_kpp + real (kind=RKIND), pointer :: config_mom_del4 + + ! State indices + integer, pointer :: indexTemperature + integer, pointer :: indexSalinity + + ! Diagnostics Indices + integer, pointer :: indexSurfaceVelocityZonal, indexSurfaceVelocityMeridional + integer, pointer :: indexSSHGradientZonal, indexSSHGradientMeridional + + ! Mesh array pointers + integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop + + ! Provis Array Pointers + real (kind=RKIND), dimension(:,:), pointer :: normalVelocityProvis, layerThicknessProvis + real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessProvis + real (kind=RKIND), dimension(:,:), pointer :: lowFreqDivergenceProvis + real (kind=RKIND), dimension(:,:,:), pointer :: tracersProvis + + ! Tend Array Pointers + real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessTend, lowFreqDivergenceTend, normalVelocityTend, layerThicknessTend + real (kind=RKIND), dimension(:,:,:), pointer :: tracersTend + + ! Diagnostics Array Pointers + real (kind=RKIND), dimension(:,:), pointer :: layerThicknessEdge + real (kind=RKIND), dimension(:,:), pointer :: vertAleTransportTop + real (kind=RKIND), dimension(:,:), pointer :: normalTransportVelocity, normalGMBolusVelocity + real (kind=RKIND), dimension(:,:), pointer :: velocityX, velocityY, velocityZ + real (kind=RKIND), dimension(:,:), pointer :: velocityZonal, velocityMeridional + real (kind=RKIND), dimension(:,:), pointer :: gradSSH + real (kind=RKIND), dimension(:,:), pointer :: gradSSHX, gradSSHY, gradSSHZ + real (kind=RKIND), dimension(:,:), pointer :: gradSSHZonal, gradSSHMeridional + real (kind=RKIND), dimension(:,:), pointer :: surfaceVelocity, sshGradient + + ! State Array Pointers + real (kind=RKIND), dimension(:,:), pointer :: normalVelocityCur, normalVelocityNew + real (kind=RKIND), dimension(:,:), pointer :: layerThicknessCur, layerThicknessNew + real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessCur, highFreqThicknessNew + real (kind=RKIND), dimension(:,:), pointer :: lowFreqDivergenceCur, lowFreqDivergenceNew + real (kind=RKIND), dimension(:), pointer :: sshCur, sshNew + + real (kind=RKIND), dimension(:,:,:), pointer :: tracers, tracersCur, tracersNew + + ! Forcing Array pointers + real (kind=RKIND), dimension(:), pointer :: seaIceEnergy + + ! Diagnostics Field Pointers + type (field1DReal), pointer :: boundaryLayerDepthField + type (field2DReal), pointer :: normalizedRelativeVorticityEdgeField, divergenceField, relativeVorticityField + + ! State/Tend Field Pointers + type (field2DReal), pointer :: highFreqThicknessField, lowFreqDivergenceField + type (field2DReal), pointer :: normalVelocityField, layerThicknessField + type (field3DReal), pointer :: tracersField + + ! Get config options + call mpas_pool_get_config(domain % configs, 'config_mom_del4', config_mom_del4) + call mpas_pool_get_config(domain % configs, 'config_filter_btr_mode', config_filter_btr_mode) + call mpas_pool_get_config(domain % configs, 'config_prescribe_velocity', config_prescribe_velocity) + call mpas_pool_get_config(domain % configs, 'config_prescribe_thickness', config_prescribe_thickness) + call mpas_pool_get_config(domain % configs, 'config_use_freq_filtered_thickness', config_use_freq_filtered_thickness) + call mpas_pool_get_config(domain % configs, 'config_use_standardGM', config_use_standardGM) + call mpas_pool_get_config(domain % configs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + + ! + ! Initialize time_levs(2) with state at current time + ! Initialize first RK state + ! Couple tracers time_levs(2) with layerThickness in time-levels + ! Initialize RK weights + ! + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + allocate(provisStatePool) + call mpas_pool_create_pool(provisStatePool) + + call mpas_pool_clone_pool(statePool, provisStatePool, 1) + call mpas_pool_add_subpool(block % structs, 'provis_state', provisStatePool) + + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) + call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceCur, 1) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceNew, 2) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + normalVelocityNew(:,:) = normalVelocityCur(:,:) + layerThicknessNew(:,:) = layerThicknessCur(:,:) + + do iCell = 1, nCells ! couple tracers to thickness + do k = 1, maxLevelCell(iCell) + tracersNew(:,k,iCell) = tracersCur(:,k,iCell) * layerThicknessCur(k,iCell) + end do + end do + + if (associated(highFreqThicknessCur)) then + highFreqThicknessNew(:,:) = highFreqThicknessCur(:,:) + end if + + if (associated(lowFreqDivergenceCur)) then + lowFreqDivergenceNew(:,:) = lowFreqDivergenceCur(:,:) + end if + + block => block % next + end do + + block => domain % blocklist + do while(associated(block)) + if (associated(block % prev)) then + call mpas_pool_get_subpool(block % prev % structs, 'provis_state', prevProvisPool) + else + nullify(prevProvisPool) + end if + + if (associated(block % next)) then + call mpas_pool_get_subpool(block % next % structs, 'provis_state', nextProvisPool) + else + nullify(nextProvisPool) + end if + + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + + if (associated(prevProvisPool) .and. associated(nextProvisPool)) then + call mpas_pool_link_pools(provisStatePool, prevProvisPool, nextProvisPool) + else if (associated(prevProvisPool)) then + call mpas_pool_link_pools(provisStatePool, prevProvisPool) + else if (associated(nextProvisPool)) then + call mpas_pool_link_pools(provisStatePool, nextPool=nextProvisPool) + else + call mpas_pool_link_pools(provisStatePool) + end if + + call mpas_pool_link_parinfo(block, provisStatePool) + + block => block % next + end do + + ! Fourth-order Runge-Kutta, solving dy/dt = f(t,y) is typically written as follows + ! where h = delta t is the large time step. Here f(t,y) is the right hand side, + ! called the tendencies in the code below. + ! k_1 = h f(t_n , y_n) + ! k_2 = h f(t_n + 1/2 h, y_n + 1/2 k_1) + ! k_3 = h f(t_n + 1/2 h, y_n + 1/2 k_2) + ! k_4 = h f(t_n + h, y_n + k_3) + ! y_{n+1} = y_n + 1/6 k_1 + 1/3 k_2 + 1/3 k_3 + 1/6 k_4 + + ! in index notation: + ! k_{j+1} = h f(t_n + a_j h, y_n + a_j k_j) + ! y_{n+1} = y_n + sum ( b_j k_j ) + + ! The coefficients of k_j are b_j = (1/6, 1/3, 1/3, 1/6) and are + ! initialized here as delta t * b_j: + + rk_weights(1) = dt/6. + rk_weights(2) = dt/3. + rk_weights(3) = dt/3. + rk_weights(4) = dt/6. + + ! The a_j coefficients of h in the computation of k_j are typically written (0, 1/2, 1/2, 1). + ! However, in the algorithm below we pre-compute the state for the tendency one iteration early. + ! That is, on j=1 (rk_step=1, below) we pre-compute y_n + 1/2 k_1 and save it in provis_state. + ! Then we compute 1/6 k_1 and add it to state % time_levs(2). + ! That is why the coefficients of h are one index early in the following, i.e. + ! a = (1/2, 1/2, 1) + + rk_substep_weights(1) = dt/2. + rk_substep_weights(2) = dt/2. + rk_substep_weights(3) = dt + rk_substep_weights(4) = dt ! a_4 only used for ALE step, otherwise it is skipped. + + call mpas_timer_start("RK4-main loop") + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! BEGIN RK loop + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do rk_step = 1, 4 + call mpas_pool_get_subpool(domain % blocklist % structs, 'diagnostics', diagnosticsPool) + + ! Update halos for diagnostic variables. + call mpas_timer_start("RK4-boundary layer depth halo update") + if (config_use_cvmix_kpp) then + call mpas_pool_get_field(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepthField) + call mpas_dmpar_exch_halo_field(boundaryLayerDepthField) + end if + call mpas_timer_stop("RK4-boundary layer depth halo update") + + call mpas_timer_start("RK4-diagnostic halo update") + + call mpas_pool_get_field(diagnosticsPool, 'normalizedRelativeVorticityEdge', normalizedRelativeVorticityEdgeField) + call mpas_pool_get_field(diagnosticsPool, 'divergence', divergenceField) + call mpas_pool_get_field(diagnosticsPool, 'relativeVorticity', relativeVorticityField) + + call mpas_dmpar_exch_halo_field(normalizedRelativeVorticityEdgeField) + if (config_mom_del4 > 0.0) then + call mpas_dmpar_exch_halo_field(divergenceField) + call mpas_dmpar_exch_halo_field(relativeVorticityField) + end if + call mpas_timer_stop("RK4-diagnostic halo update") + + ! Compute tendencies for high frequency thickness + ! In RK4 notation, we are computing the right hand side f(t,y), + ! which is the same as k_j / h. + + if (config_use_freq_filtered_thickness) then + call mpas_timer_start("RK4-tendency computations") + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + + call ocn_tend_freq_filtered_thickness(tendPool, provisStatePool, diagnosticsPool, meshPool, 1) + block => block % next + end do + call mpas_timer_stop("RK4-tendency computations") + + call mpas_timer_start("RK4-prognostic halo update") + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + + call mpas_pool_get_field(tendPool, 'highFreqThickness', highFreqThicknessField) + call mpas_pool_get_field(tendPool, 'lowFreqDivergence', lowFreqDivergenceField) + + call mpas_dmpar_exch_halo_field(highFreqThicknessField) + call mpas_dmpar_exch_halo_field(lowFreqDivergenceField) + call mpas_timer_stop("RK4-prognostic halo update") + + ! Compute next substep state for high frequency thickness. + ! In RK4 notation, we are computing y_n + a_j k_j. + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) + call mpas_pool_get_array(provisStatePool, 'highFreqThickness', highFreqThicknessProvis, 1) + call mpas_pool_get_array(tendPool, 'highFreqThickness', highFreqThicknessTend) + + highFreqThicknessProvis(:,:) = highFreqThicknessCur(:,:) + rk_substep_weights(rk_step) * highFreqThicknessTend(:,:) + block => block % next + end do + + endif + + ! Compute tendencies for velocity, thickness, and tracers. + ! In RK4 notation, we are computing the right hand side f(t,y), + ! which is the same as k_j / h. + call mpas_timer_start("RK4-tendency computations") + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'ssh', sshCur, 1) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) + + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertAleTransportTop', vertAleTransportTop) + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + + call mpas_pool_get_array(provisStatePool, 'normalVelocity', normalVelocityProvis, 1) + call mpas_pool_get_array(provisStatePool, 'highFreqThickness', highFreqThicknessProvis, 1) + + ! advection of u uses u, while advection of layerThickness and tracers use normalTransportVelocity. + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + layerThicknessCur,layerThicknessEdge, normalVelocityProvis, & + sshCur, highFreqThicknessProvis, rk_substep_weights(rk_step), & + vertAleTransportTop, err) + + call ocn_tend_vel(tendPool, provisStatePool, forcingPool, diagnosticsPool, meshPool, scratchPool, 1) + + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + layerThicknessCur, layerThicknessEdge, normalTransportVelocity, & + sshCur, highFreqThicknessProvis, rk_substep_weights(rk_step), & + vertAleTransportTop, err) + + call ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool) + + if (config_filter_btr_mode) then + call ocn_filter_btr_mode_tend_vel(tendPool, provisStatePool, diagnosticsPool, meshPool, 1) + endif + + call ocn_tend_tracer(tendPool, provisStatePool, forcingPool, diagnosticsPool, meshPool, scratchPool, dt, 1) + block => block % next + end do + call mpas_timer_stop("RK4-tendency computations") + + ! Update halos for prognostic variables. + + call mpas_timer_start("RK4-prognostic halo update") + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + + call mpas_pool_get_field(tendPool, 'normalVelocity', normalVelocityField) + call mpas_pool_get_field(tendPool, 'layerThickness', layerThicknessField) + call mpas_pool_get_field(tendPool, 'tracers', tracersField) + + call mpas_dmpar_exch_halo_field(normalVelocityField) + call mpas_dmpar_exch_halo_field(layerThicknessField) + call mpas_dmpar_exch_halo_field(tracersField) + call mpas_timer_stop("RK4-prognostic halo update") + + ! Compute next substep state for velocity, thickness, and tracers. + ! In RK4 notation, we are computing y_n + a_j k_j. + + call mpas_timer_start("RK4-update diagnostic variables") + if (rk_step < 4) then + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceCur, 1) + + call mpas_pool_get_array(provisStatePool, 'normalVelocity', normalVelocityProvis, 1) + call mpas_pool_get_array(provisStatePool, 'layerThickness', layerThicknessProvis, 1) + call mpas_pool_get_array(provisStatePool, 'tracers', tracersProvis, 1) + call mpas_pool_get_array(provisStatePool, 'lowFreqDivergence', lowFreqDivergenceProvis, 1) + + call mpas_pool_get_array(tendPool, 'normalVelocity', normalVelocityTend) + call mpas_pool_get_array(tendPool, 'layerThickness', layerThicknessTend) + call mpas_pool_get_array(tendPool, 'tracers', tracersTend) + call mpas_pool_get_array(tendPool, 'lowFreqDivergence', lowFreqDivergenceTend) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + + normalVelocityProvis(:,:) = normalVelocityCur(:,:) + rk_substep_weights(rk_step) * normalVelocityTend(:,:) + + layerThicknessProvis(:,:) = layerThicknessCur(:,:) + rk_substep_weights(rk_step) * layerThicknessTend(:,:) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersProvis(:,k,iCell) = ( layerThicknessCur(k,iCell) * tracersCur(:,k,iCell) & + + rk_substep_weights(rk_step) * tracersTend(:,k,iCell) & + ) / layerThicknessProvis(k,iCell) + end do + + end do + + if (associated(lowFreqDivergenceCur)) then + lowFreqDivergenceProvis(:,:) = lowFreqDivergenceCur(:,:) + rk_substep_weights(rk_step) * lowFreqDivergenceTend(:,:) + end if + + if (config_prescribe_velocity) then + normalVelocityProvis(:,:) = normalVelocityCur(:,:) + end if + + if (config_prescribe_thickness) then + layerThicknessProvis(:,:) = layerThicknessCur(:,:) + end if + + call ocn_diagnostic_solve(dt, provisStatePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 1) + + ! ------------------------------------------------------------------ + ! Accumulating various parametrizations of the transport velocity + ! ------------------------------------------------------------------ + normalTransportVelocity(:,:) = normalVelocityProvis(:,:) + + ! Compute normalGMBolusVelocity, relativeSlope and RediDiffVertCoef if respective flags are turned on + if (config_use_standardGM) then + call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) + end if + + if (config_use_standardGM) then + normalTransportVelocity(:,:) = normalTransportVelocity(:,:) + normalGMBolusVelocity(:,:) + end if + ! ------------------------------------------------------------------ + ! End: Accumulating various parametrizations of the transport velocity + ! ------------------------------------------------------------------ + + block => block % next + end do + end if + call mpas_timer_stop("RK4-update diagnostic variables") + + ! Accumulate update. + ! In RK4 notation, we are computing b_j k_j and adding it to an accumulating sum so that we have + ! y_{n+1} = y_n + sum ( b_j k_j ) + ! after the fourth iteration. + + call mpas_timer_start("RK4-RK4 accumulate update") + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceCur, 1) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceNew, 2) + + call mpas_pool_get_array(tendPool, 'normalVelocity', normalVelocityTend) + call mpas_pool_get_array(tendPool, 'layerThickness', layerThicknessTend) + call mpas_pool_get_array(tendPool, 'tracers', tracersTend) + call mpas_pool_get_array(tendPool, 'highFreqThickness', highFreqThicknessTend) + call mpas_pool_get_array(tendPool, 'lowFreqDivergence', lowFreqDivergenceTend) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + normalVelocityNew(:,:) = normalVelocityNew(:,:) + rk_weights(rk_step) * normalVelocityTend(:,:) + + layerThicknessNew(:,:) = layerThicknessNew(:,:) + rk_weights(rk_step) * layerThicknessTend(:,:) + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersTend(:,k,iCell) + end do + end do + + if (associated(highFreqThicknessNew)) then + highFreqThicknessNew(:,:) = highFreqThicknessNew(:,:) + rk_weights(rk_step) * highFreqThicknessTend(:,:) + end if + + if (associated(lowFreqDivergenceNew)) then + lowFreqDivergenceNew(:,:) = lowFreqDivergenceNew(:,:) + rk_weights(rk_step) * lowFreqDivergenceTend(:,:) + end if + + block => block % next + end do + call mpas_timer_stop("RK4-RK4 accumulate update") + + end do + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! END RK loop + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call mpas_timer_stop("RK4-main loop") + + ! + ! A little clean up at the end: rescale tracer fields and compute diagnostics for new state + ! + call mpas_timer_start("RK4-cleaup phase") + + ! Rescale tracers + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) + + call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(forcingPool, 'seaIceEnergy', seaIceEnergy) + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersNew(:, k, iCell) = tracersNew(:, k, iCell) / layerThicknessNew(k, iCell) + end do + end do + + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, layerThicknessNew, tracersNew, seaIceEnergy, err) + block => block % next + end do + + call mpas_timer_start("RK4-implicit vert mix") + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + + ! 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 density, layerThicknessEdge, and kineticEnergyCell 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. + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + + call ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, 2) + + ! ------------------------------------------------------------------ + ! Accumulating various parametrizations of the transport velocity + ! ------------------------------------------------------------------ + normalTransportVelocity(:,:) = normalVelocityNew(:,:) + + ! Compute normalGMBolusVelocity, slopeRelative and RediDiffVertCoef if respective flags are turned on + ! QC Note: this routine is called here to get updated k33. normalTransportVelocity probably does not need to be updated at all here. + if (config_use_standardGM) then + call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) + end if + + if (config_use_standardGM) then + normalTransportVelocity(:,:) = normalTransportVelocity(:,:) + normalGMBolusVelocity(:,:) + end if + ! ------------------------------------------------------------------ + ! End: Accumulating various parametrizations of the transport velocity + ! ------------------------------------------------------------------ + + 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_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + + call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocityField, 2) + call mpas_pool_get_field(statePool, 'tracers', tracersField, 2) + + call mpas_dmpar_exch_halo_field(normalVelocityField) + call mpas_dmpar_exch_halo_field(tracersField) + call mpas_timer_stop("RK4-implicit vert mix halos") + + call mpas_timer_stop("RK4-implicit vert mix") + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'average', averagePool) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) + + call mpas_pool_get_dimension(diagnosticsPool, 'index_surfaceVelocityZonal', indexSurfaceVelocityZonal) + call mpas_pool_get_dimension(diagnosticsPool, 'index_surfaceVelocityMeridional', indexSurfaceVelocityMeridional) + call mpas_pool_get_dimension(diagnosticsPool, 'index_SSHGradientZonal', indexSSHGradientZonal) + call mpas_pool_get_dimension(diagnosticsPool, 'index_SSHGradientMeridional', indexSSHGradientMeridional) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'velocityX', velocityX) + call mpas_pool_get_array(diagnosticsPool, 'velocityY', velocityY) + call mpas_pool_get_array(diagnosticsPool, 'velocityZ', velocityZ) + call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) + call mpas_pool_get_array(diagnosticsPool, 'gradSSH', gradSSH) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHX', gradSSHX) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHY', gradSSHY) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHZ', gradSSHZ) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHZonal', gradSSHZonal) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHMeridional', gradSSHMeridional) + call mpas_pool_get_array(diagnosticsPool, 'surfaceVelocity', surfaceVelocity) + call mpas_pool_get_array(diagnosticsPool, 'SSHGradient', SSHGradient) + + if (config_prescribe_velocity) then + normalVelocityNew(:,:) = normalVelocityCur(:,:) + end if + + if (config_prescribe_thickness) then + layerThicknessNew(:,:) = layerThicknessCur(:,:) + end if + + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + + ! ------------------------------------------------------------------ + ! Accumulating various parameterizations of the transport velocity + ! ------------------------------------------------------------------ + normalTransportVelocity(:,:) = normalVelocityNew(:,:) + + ! Compute normalGMBolusVelocity and the tracer transport velocity + if (config_use_standardGM) then + call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) + end if + + if (config_use_standardGM) then + normalTransportVelocity(:,:) = normalTransportVelocity(:,:) + normalGMBolusVelocity(:,:) + end if + ! ------------------------------------------------------------------ + ! End: Accumulating various parameterizations of the transport velocity + ! ------------------------------------------------------------------ + + call mpas_reconstruct(meshPool, normalVelocityNew, & + velocityX, velocityY, velocityZ, & + velocityZonal, velocityMeridional & + ) + + call mpas_reconstruct(meshPool, gradSSH, & + gradSSHX, gradSSHY, gradSSHZ, & + gradSSHZonal, gradSSHMeridional & + ) + + surfaceVelocity(indexSurfaceVelocityZonal, :) = velocityZonal(1, :) + surfaceVelocity(indexSurfaceVelocityMeridional, :) = velocityMeridional(1, :) + + SSHGradient(indexSSHGradientZonal, :) = gradSSHZonal(1, :) + SSHGradient(indexSSHGradientMeridional, :) = gradSSHMeridional(1, :) + + call ocn_time_average_accumulate(averagePool, statePool, diagnosticsPool, 2) + call ocn_time_average_coupled_accumulate(diagnosticsPool, forcingPool) + + if (config_use_standardGM) then + call ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) + end if + + block => block % next + end do + call mpas_timer_stop("RK4-cleaup phase") + + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + + call mpas_pool_destroy_pool(provisStatePool) + + call mpas_pool_remove_subpool(block % structs, 'provis_state') + block => block % next + end do + + end subroutine ocn_time_integrator_rk4!}}} + +end module ocn_time_integration_rk4 + +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F new file mode 100644 index 0000000000..d85a9c9bc5 --- /dev/null +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -0,0 +1,1539 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_time_integration_split +! +!> \brief MPAS ocean split explicit time integration scheme +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date September 2011 +!> \details +!> This module contains the routine for the split explicit +!> time integration scheme +! +!----------------------------------------------------------------------- + + +module ocn_time_integration_split + + use mpas_grid_types + use mpas_constants + use mpas_dmpar + use mpas_vector_reconstruction + use mpas_spline_interpolation + use mpas_timer + + use ocn_tendency + use ocn_diagnostics + use ocn_gm + + use ocn_equation_of_state + use ocn_vmix + use ocn_time_average + use ocn_time_average_coupled + + use ocn_sea_ice + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_time_integrator_split + + type (timer_node), pointer :: timer_main, timer_prep, timer_bcl_vel, timer_btr_vel, timer_diagnostic_update, timer_implicit_vmix, & + timer_halo_diagnostic, timer_halo_normalBarotropicVelocity, timer_halo_ssh, timer_halo_f, timer_halo_thickness, & + timer_halo_tracers, timer_halo_normalBaroclinicVelocity + + contains + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_time_integration_split +! +!> \brief MPAS ocean split explicit time integration scheme +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine integrates a single time step (dt) using a +!> split explicit time integrator. +! +!----------------------------------------------------------------------- + + subroutine ocn_time_integrator_split(domain, dt)!{{{ + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Advance model state forward in time by the specified time step using + ! Split_Explicit timestepping scheme + ! + ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:)) + ! plus mesh meta-data + ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains + ! model state advanced forward in time by dt seconds + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + implicit none + + type (domain_type), intent(inout) :: domain + real (kind=RKIND), intent(in) :: dt + + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: verticalMeshPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: tendPool + type (mpas_pool_type), pointer :: forcingPool + type (mpas_pool_type), pointer :: averagePool + type (mpas_pool_type), pointer :: scratchPool + + type (dm_info) :: dminfo + integer :: iCell, i,k,j, iEdge, cell1, cell2, split_explicit_step, split, & + eoe, oldBtrSubcycleTime, newBtrSubcycleTime, uPerpTime, BtrCorIter, & + stage1_tend_time + integer, dimension(:), allocatable :: n_bcl_iter + type (block_type), pointer :: block + real (kind=RKIND) :: normalThicknessFluxSum, thicknessSum, flux, sshEdge, hEdge1, & + CoriolisTerm, normalVelocityCorrection, temp, temp_h, coef, barotropicThicknessFlux_coeff, sshCell1, sshCell2 + integer :: useVelocityCorrection, err + real (kind=RKIND), dimension(:,:), pointer :: & + vertViscTopOfEdge, vertDiffTopOfCell + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:), allocatable:: uTemp + real (kind=RKIND), dimension(:,:), allocatable:: tracersTemp + + integer :: tsIter + + ! Config options + character (len=StrKIND), pointer :: config_time_integrator + integer, pointer :: config_n_bcl_iter_mid, config_n_bcl_iter_beg, config_n_bcl_iter_end + integer, pointer :: config_n_ts_iter, config_btr_subcycle_loop_factor, config_n_btr_subcycles + integer, pointer :: config_n_btr_cor_iter + logical, pointer :: config_use_standardGM + + logical, pointer :: config_use_freq_filtered_thickness, config_btr_solve_SSH2, config_filter_btr_mode + logical, pointer :: config_vel_correction, config_prescribe_velocity, config_prescribe_thickness + logical, pointer :: config_use_cvmix_kpp + + real (kind=RKIND), pointer :: config_mom_del4, config_btr_gam1_velWt1, config_btr_gam2_SSHWt1 + real (kind=RKIND), pointer :: config_btr_gam3_velWt2 + + ! Dimensions + integer, pointer :: nCells, nEdges, nVertLevels, num_tracers, startIndex, endIndex + integer, pointer :: indexTemperature, indexSalinity + integer, pointer :: indexSurfaceVelocityZonal, indexSurfaceVelocityMeridional + integer, pointer :: indexSSHGradientZonal, indexSSHGradientMeridional + + ! Mesh array pointers + integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, nEdgesOnEdge, nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask, edgesOnEdge + integer, dimension(:,:), pointer :: edgesOnCell, edgeSignOnCell + + real (kind=RKIND), dimension(:), pointer :: dcEdge, fEdge, bottomDepth, refBottomDepthTopOfCell + real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell + real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + + ! State Array Pointers + real (kind=RKIND), dimension(:), pointer :: sshSubcycleCur, sshSubcycleNew + real (kind=RKIND), dimension(:), pointer :: normalBarotropicVelocitySubcycleCur, normalBarotropicVelocitySubcycleNew + real (kind=RKIND), dimension(:), pointer :: sshCur, sshNew + real (kind=RKIND), dimension(:), pointer :: normalBarotropicVelocityCur, normalBarotropicVelocityNew + real (kind=RKIND), dimension(:,:), pointer :: normalBaroclinicVelocityCur, normalBaroclinicVelocityNew + real (kind=RKIND), dimension(:,:), pointer :: normalVelocityCur, normalVelocityNew + real (kind=RKIND), dimension(:,:), pointer :: layerThicknessCur, layerThicknessNew + real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessCur, highFreqThicknessNew + real (kind=RKIND), dimension(:,:), pointer :: lowFreqDivergenceCur, lowFreqDivergenceNew + real (kind=RKIND), dimension(:,:,:), pointer :: tracersCur, tracersNew + + ! Tend Array Pointers + real (kind=RKIND), dimension(:), pointer :: sshTend + real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessTend + real (kind=RKIND), dimension(:,:), pointer :: lowFreqDivergenceTend + real (kind=RKIND), dimension(:,:), pointer :: normalVelocityTend, layerThicknessTend + real (kind=RKIND), dimension(:,:,:), pointer :: tracersTend + + ! Diagnostics Array Pointers + real (kind=RKIND), dimension(:), pointer :: barotropicForcing, barotropicThicknessFlux + real (kind=RKIND), dimension(:,:), pointer :: layerThicknessEdge, normalTransportVelocity, normalGMBolusVelocity + real (kind=RKIND), dimension(:,:), pointer :: vertAleTransportTop + real (kind=RKIND), dimension(:,:), pointer :: velocityX, velocityY, velocityZ + real (kind=RKIND), dimension(:,:), pointer :: velocityZonal, velocityMeridional + real (kind=RKIND), dimension(:,:), pointer :: gradSSH + real (kind=RKIND), dimension(:,:), pointer :: gradSSHX, gradSSHY, gradSSHZ + real (kind=RKIND), dimension(:,:), pointer :: gradSSHZonal, gradSSHMeridional + real (kind=RKIND), dimension(:,:), pointer :: surfaceVelocity, SSHGradient + + ! Forcing Array Pointer + real (kind=RKIND), dimension(:), pointer :: seaIceEnergy + + ! Diagnostics Field Pointers + type (field2DReal), pointer :: normalizedRelativeVorticityEdgeField, divergenceField, relativeVorticityField + type (field1DReal), pointer :: barotropicThicknessFluxField, boundaryLayerDepthField + + ! State/Tend Field Pointers + type (field1DReal), pointer :: normalBarotropicVelocitySubcycleField, sshSubcycleField + type (field2DReal), pointer :: highFreqThicknessField, lowFreqDivergenceField + type (field2DReal), pointer :: normalBaroclinicVelocityField, layerThicknessField + type (field2DReal), pointer :: normalVelocityField + type (field3DReal), pointer :: tracersField + + call mpas_timer_start("se timestep", .false., timer_main) + + call mpas_pool_get_config(domain % configs, 'config_n_bcl_iter_beg', config_n_bcl_iter_beg) + call mpas_pool_get_config(domain % configs, 'config_n_bcl_iter_mid', config_n_bcl_iter_mid) + call mpas_pool_get_config(domain % configs, 'config_n_bcl_iter_end', config_n_bcl_iter_end) + call mpas_pool_get_config(domain % configs, 'config_n_ts_iter', config_n_ts_iter) + call mpas_pool_get_config(domain % configs, 'config_n_btr_subcycles', config_n_btr_subcycles) + call mpas_pool_get_config(domain % configs, 'config_btr_subcycle_loop_factor', config_btr_subcycle_loop_factor) + call mpas_pool_get_config(domain % configs, 'config_btr_gam1_velWt1', config_btr_gam1_velWt1) + call mpas_pool_get_config(domain % configs, 'config_btr_gam3_velWt2', config_btr_gam3_velWt2) + call mpas_pool_get_config(domain % configs, 'config_btr_solve_SSH2', config_btr_solve_SSH2) + call mpas_pool_get_config(domain % configs, 'config_n_btr_cor_iter', config_n_btr_cor_iter) + call mpas_pool_get_config(domain % configs, 'config_btr_gam2_SSHWt1', config_btr_gam2_SSHWt1) + call mpas_pool_get_config(domain % configs, 'config_filter_btr_mode', config_filter_btr_mode) + + call mpas_pool_get_config(domain % configs, 'config_mom_del4', config_mom_del4) + call mpas_pool_get_config(domain % configs, 'config_use_freq_filtered_thickness', config_use_freq_filtered_thickness) + call mpas_pool_get_config(domain % configs, 'config_time_integrator', config_time_integrator) + call mpas_pool_get_config(domain % configs, 'config_vel_correction', config_vel_correction) + + call mpas_pool_get_config(domain % configs, 'config_prescribe_velocity', config_prescribe_velocity) + call mpas_pool_get_config(domain % configs, 'config_prescribe_thickness', config_prescribe_thickness) + + call mpas_pool_get_config(domain % configs, 'config_prescribe_velocity', config_prescribe_velocity) + call mpas_pool_get_config(domain % configs, 'config_prescribe_thickness', config_prescribe_thickness) + + call mpas_pool_get_config(domain % configs, 'config_use_standardGM', config_use_standardGM) + call mpas_pool_get_config(domain % configs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + + allocate(n_bcl_iter(config_n_ts_iter)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Prep variables before first iteration + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call mpas_timer_start("se prep", .false., timer_prep) + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) + + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityNew, 2) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) + + call mpas_pool_get_array(statePool, 'ssh', sshCur, 1) + call mpas_pool_get_array(statePool, 'ssh', sshNew, 2) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) + + call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) + + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceCur, 1) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceNew, 2) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + ! Initialize * variables that are used to compute baroclinic tendencies below. + do iEdge = 1, nEdges + do k = 1, nVertLevels !maxLevelEdgeTop % array(iEdge) + + ! 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 normalBarotropicVelocity from the previous timestep. + ! Note that normalBaroclinicVelocity may now include a barotropic component, because the + ! weights layerThickness have changed. That is OK, because the barotropicForcing variable + ! subtracts out the barotropic component from the baroclinic. + normalBaroclinicVelocityCur(k,iEdge) = normalVelocityCur(k,iEdge) - normalBarotropicVelocityCur(iEdge) + + normalVelocityNew(k,iEdge) = normalVelocityCur(k,iEdge) + + normalBaroclinicVelocityNew(k,iEdge) = normalBaroclinicVelocityCur(k,iEdge) + + ! DWJ-POOL What's this for? +! block % diagnostics % layerThicknessEdge % array(k,iEdge) & +! = block % diagnostics % layerThicknessEdge % array(k,iEdge) + end do + end do + + sshNew(:) = sshCur(:) + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + layerThicknessNew(k,iCell) = layerThicknessCur(k,iCell) + + tracersNew(:,k,iCell) = tracersCur(:,k,iCell) + end do + end do + + if (associated(highFreqThicknessNew)) then + highFreqThicknessNew(:,:) = highFreqThicknessCur(:,:) + end if + + if (associated(lowFreqDivergenceNew)) then + lowFreqDivergenceNew(:,:) = lowFreqDivergenceCur(:,:) + endif + + block => block % next + end do + + call mpas_timer_stop("se prep", timer_prep) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! BEGIN large iteration loop + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + n_bcl_iter = config_n_bcl_iter_mid + n_bcl_iter(1) = config_n_bcl_iter_beg + n_bcl_iter(config_n_ts_iter) = config_n_bcl_iter_end + + do split_explicit_step = 1, config_n_ts_iter + stage1_tend_time = min(split_explicit_step,2) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'diagnostics', diagnosticsPool) + + ! --- update halos for diagnostic ocean boundayr layer depth + call mpas_timer_start("se halo diag obd", .false., timer_halo_diagnostic) + if (config_use_cvmix_kpp) then + call mpas_pool_get_field(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepthField) + call mpas_dmpar_exch_halo_field(boundaryLayerDepthField) + end if + call mpas_timer_stop("se halo diag obd") + + ! --- update halos for diagnostic variables + call mpas_timer_start("se halo diag", .false., timer_halo_diagnostic) + + call mpas_pool_get_field(diagnosticsPool, 'normalizedRelativeVorticityEdge', normalizedRelativeVorticityEdgeField) + call mpas_pool_get_field(diagnosticsPool, 'divergence', divergenceField) + call mpas_pool_get_field(diagnosticsPool, 'relativeVorticity', relativeVorticityField) + call mpas_dmpar_exch_halo_field(normalizedRelativeVorticityEdgeField) + if (config_mom_del4 > 0.0) then + call mpas_dmpar_exch_halo_field(divergenceField) + call mpas_dmpar_exch_halo_field(relativeVorticityField) + end if + call mpas_timer_stop("se halo diag", timer_halo_diagnostic) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Stage 1: Baroclinic velocity (3D) prediction, explicit with long timestep + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (config_use_freq_filtered_thickness) then + call mpas_timer_start("se freq-filtered-thick computations") + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'state', statepool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call ocn_tend_freq_filtered_thickness(tendPool, statePool, diagnosticsPool, meshPool, stage1_tend_time) + block => block % next + end do + call mpas_timer_stop("se freq-filtered-thick computations") + + call mpas_timer_start("se freq-filtered-thick halo update") + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + + call mpas_pool_get_field(tendPool, 'highFreqThickness', highFreqThicknessField) + call mpas_pool_get_field(tendPool, 'lowFreqDivergence', lowFreqDivergenceField) + + call mpas_dmpar_exch_halo_field(highFreqThicknessField) + call mpas_dmpar_exch_halo_field(lowFreqDivergenceField) + call mpas_timer_stop("se freq-filtered-thick halo update") + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) + + call mpas_pool_get_array(tendPool, 'highFreqThickness', highFreqThicknessTend) + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + ! this is h^{hf}_{n+1} + highFreqThicknessNew(k,iCell) = highFreqThicknessCur(k,iCell) + dt * highFreqThicknessTend(k,iCell) + end do + end do + block => block % next + end do + + endif + + + ! compute velocity tendencies, T(u*,w*,p*) + call mpas_timer_start("se bcl vel", .false., timer_bcl_vel) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, stage1_tend_time) + call mpas_pool_get_array(statePool, 'ssh', sshCur, 1) + + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) + + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertAleTransportTop', vertAleTransportTop) + + ! compute vertAleTransportTop. Use u (rather than normalTransportVelocity) for momentum advection. + ! Use the most recent time level available. + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + layerThicknessCur, layerThicknessEdge, normalVelocityCur, & + sshCur, highFreqThicknessNew, dt, vertAleTransportTop, err) + + call ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshPool, scratchPool, stage1_tend_time) + + block => block % next + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! BEGIN baroclinic iterations on linear Coriolis term + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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_integrator) == 'unsplit_explicit') then + split = 0 + elseif (trim(config_time_integrator) == 'split_explicit') then + split = 1 + endif + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityNew, 2) + call mpas_pool_get_array(statePool, 'ssh', sshNew, 2) + + call mpas_pool_get_array(tendPool, 'normalVelocity', normalVelocityTend) + + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'barotropicForcing', barotropicForcing) + + allocate(uTemp(nVertLevels)) + + ! Put f*normalBaroclinicVelocity^{perp} in uNew as a work variable + call ocn_fuperp(statePool, meshPool, 2) + + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + uTemp = 0.0 ! could put this after with uTemp(maxleveledgetop+1:nvertlevels)=0 + do k = 1, maxLevelEdgeTop(iEdge) + + ! normalBaroclinicVelocityNew = normalBaroclinicVelocityOld + dt*(-f*normalBaroclinicVelocityPerp + T(u*,w*,p*) + g*grad(SSH*) ) + ! Here uNew is a work variable containing -fEdge(iEdge)*normalBaroclinicVelocityPerp(k,iEdge) + uTemp(k) = normalBaroclinicVelocityCur(k,iEdge) & + + dt * (normalVelocityTend(k,iEdge) & + + normalVelocityNew(k,iEdge) & ! this is f*normalBaroclinicVelocity^{perp} + + split * gravity * ( sshNew(cell2) - sshNew(cell1) ) & + / dcEdge(iEdge) ) + enddo + + ! thicknessSum is initialized outside the loop because on land boundaries + ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a + ! nonzero value to avoid a NaN. + normalThicknessFluxSum = layerThicknessEdge(1,iEdge) * uTemp(1) + thicknessSum = layerThicknessEdge(1,iEdge) + + do k = 2, maxLevelEdgeTop(iEdge) + normalThicknessFluxSum = normalThicknessFluxSum + layerThicknessEdge(k,iEdge) * uTemp(k) + thicknessSum = thicknessSum + layerThicknessEdge(k,iEdge) + enddo + barotropicForcing(iEdge) = split * normalThicknessFluxSum / thicknessSum / dt + + + do k = 1, maxLevelEdgeTop(iEdge) + ! These two steps are together here: + !{\bf u}'_{k,n+1} = {\bf u}'_{k,n} - \Delta t {\overline {\bf G}} + !{\bf u}'_{k,n+1/2} = \frac{1}{2}\left({\bf u}^{'}_{k,n} +{\bf u}'_{k,n+1}\right) + ! so that normalBaroclinicVelocityNew is at time n+1/2 + normalBaroclinicVelocityNew(k,iEdge) = 0.5*( & + normalBaroclinicVelocityCur(k,iEdge) + uTemp(k) - dt * barotropicForcing(iEdge)) + + enddo + + enddo ! iEdge + + deallocate(uTemp) + + block => block % next + end do + + call mpas_timer_start("se halo normalBaroclinicVelocity", .false., timer_halo_normalBaroclinicVelocity) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityField, 2) + + call mpas_dmpar_exch_halo_field(normalBaroclinicVelocityField) + call mpas_timer_stop("se halo normalBaroclinicVelocity", timer_halo_normalBaroclinicVelocity) + + end do ! do j=1,config_n_bcl_iter + + call mpas_timer_stop("se bcl vel", timer_bcl_vel) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! END baroclinic iterations on linear Coriolis term + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Stage 2: Barotropic velocity (2D) prediction, explicitly subcycled + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call mpas_timer_start("se btr vel", .false., timer_btr_vel) + + oldBtrSubcycleTime = 1 + newBtrSubcycleTime = 2 + + if (trim(config_time_integrator) == 'unsplit_explicit') then + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityNew, 2) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + + ! For Split_Explicit unsplit, simply set normalBarotropicVelocityNew=0, normalBarotropicVelocitySubcycle=0, and uNew=normalBaroclinicVelocityNew + normalBarotropicVelocityNew(:) = 0.0 + + normalVelocityNew(:,:) = normalBaroclinicVelocityNew(:,:) + + do iEdge = 1, nEdges + do k = 1, nVertLevels + + ! normalTransportVelocity = normalBaroclinicVelocity + normalGMBolusVelocity + ! This is u used in advective terms for layerThickness and tracers + ! in tendency calls in stage 3. +!mrp note: in QC version, there is an if (config_use_standardGM) on adding normalGMBolusVelocity +! I think it is not needed because normalGMBolusVelocity=0 when GM not on. + normalTransportVelocity(k,iEdge) = edgeMask(k,iEdge) & + *( normalBaroclinicVelocityNew(k,iEdge) + normalGMBolusVelocity(k,iEdge) ) + + enddo + end do ! iEdge + + block => block % next + end do ! block + + elseif (trim(config_time_integrator) == 'split_explicit') then + + ! Initialize variables for barotropic subcycling + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + call mpas_pool_get_array(diagnosticsPool, 'barotropicForcing', barotropicForcing) + call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) + + call mpas_pool_get_array(statePool, 'ssh', sshCur, 1) + call mpas_pool_get_array(statePool, 'sshSubcycle', sshSubcycleCur, oldBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleCur, oldBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) + + if (config_filter_btr_mode) then + barotropicForcing(:) = 0.0 + endif + + do iCell = 1, nCells + ! sshSubcycleOld = sshOld + sshSubcycleCur(iCell) = sshCur(iCell) + end do + + do iEdge = 1, nEdges + + ! normalBarotropicVelocitySubcycleOld = normalBarotropicVelocityOld + normalBarotropicVelocitySubcycleCur(iEdge) = normalBarotropicVelocityCur(iEdge) + + ! normalBarotropicVelocityNew = BtrOld This is the first for the summation + normalBarotropicVelocityNew(iEdge) = normalBarotropicVelocityCur(iEdge) + + ! barotropicThicknessFlux = 0 + barotropicThicknessFlux(iEdge) = 0.0 + end do + + block => block % next + end do ! block + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! BEGIN Barotropic subcycle loop + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do j = 1, config_n_btr_subcycles * config_btr_subcycle_loop_factor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Barotropic subcycle: VELOCITY PREDICTOR STEP + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (config_btr_gam1_velWt1 > 1.0e-12) then ! only do this part if it is needed in next SSH solve + uPerpTime = oldBtrSubcycleTime + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(meshPool, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleCur, uPerpTime) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'sshSubcycle', sshSubcycleCur, oldBtrSubcycleTime) + + call mpas_pool_get_array(diagnosticsPool, 'barotropicForcing', barotropicForcing) + + do iEdge = 1, nEdges + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! Compute the barotropic Coriolis term, -f*uPerp + CoriolisTerm = 0.0 + do i = 1, nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(i,iEdge) + CoriolisTerm = CoriolisTerm + weightsOnEdge(i,iEdge) & + * normalBarotropicVelocitySubcycleCur(eoe) * fEdge(eoe) + end do + + ! normalBarotropicVelocityNew = normalBarotropicVelocityOld + dt/J*(-f*normalBarotropicVelocityoldPerp - g*grad(SSH) + G) + normalBarotropicVelocitySubcycleNew(iEdge) & + = (normalBarotropicVelocitySubcycleCur(iEdge) & + + dt / config_n_btr_subcycles * (CoriolisTerm - gravity & + * (sshSubcycleCur(cell2) - sshSubcycleCur(cell1) ) & + / dcEdge(iEdge) + barotropicForcing(iEdge))) * edgeMask(1, iEdge) + end do + + block => block % next + end do ! block + + ! boundary update on normalBarotropicVelocityNew + call mpas_timer_start("se halo normalBarotropicVelocity", .false., timer_halo_normalBarotropicVelocity) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + + call mpas_pool_get_field(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleField, newBtrSubcycleTime) + call mpas_dmpar_exch_halo_field(normalBarotropicVelocitySubcycleField) + call mpas_timer_stop("se halo normalBarotropicVelocity", timer_halo_normalBarotropicVelocity) + endif ! config_btr_gam1_velWt1>1.0e-12 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Barotropic subcycle: SSH PREDICTOR STEP + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_array(tendPool, 'ssh', sshTend) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'refBottomDepthTopOfCell', refBottomDepthTopOfCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + + call mpas_pool_get_array(statePool, 'sshSubcycle', sshSubcycleCur, oldBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'sshSubcycle', sshSubcycleNew, newBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleCur, oldBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) + + call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) + + sshTend(:) = 0.0 + + if (config_btr_solve_SSH2) then + ! If config_btr_solve_SSH2=.true., then do NOT accumulate barotropicThicknessFlux in this SSH predictor + ! section, because it will be accumulated in the SSH corrector section. + barotropicThicknessFlux_coeff = 0.0 + else + ! otherwise, DO accumulate barotropicThicknessFlux in this SSH predictor section + barotropicThicknessFlux_coeff = 1.0 + endif + + ! config_btr_gam1_velWt1 sets the forward weighting of velocity in the SSH computation + ! config_btr_gam1_velWt1= 1 flux = normalBarotropicVelocityNew*H + ! config_btr_gam1_velWt1=0.5 flux = 1/2*(normalBarotropicVelocityNew+normalBarotropicVelocityOld)*H + ! config_btr_gam1_velWt1= 0 flux = normalBarotropicVelocityOld*H + + do iCell = 1, nCells + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + + sshEdge = 0.5 * (sshSubcycleCur(cell1) + sshSubcycleCur(cell2) ) + + ! method 0: orig, works only without pbc: + !thicknessSum = sshEdge + refBottomDepthTopOfCell(maxLevelEdgeTop(iEdge)+1) + + ! method 1, matches method 0 without pbcs, works with pbcs. + thicknessSum = sshEdge + min(bottomDepth(cell1), bottomDepth(cell2)) + + ! method 2: may be better than method 1. + ! Take average of full thickness at two neighboring cells. + !thicknessSum = sshEdge + 0.5 *( bottomDepth(cell1) + bottomDepth(cell2) ) + + + flux = ((1.0-config_btr_gam1_velWt1) * normalBarotropicVelocitySubcycleCur(iEdge) & + + config_btr_gam1_velWt1 * normalBarotropicVelocitySubcycleNew(iEdge)) & + * thicknessSum + + sshTend(iCell) = sshTend(iCell) + edgeSignOncell(i, iCell) * flux & + * dvEdge(iEdge) + + end do + end do + + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + sshEdge = 0.5 * (sshSubcycleCur(cell1) & + + sshSubcycleCur(cell2) ) + + ! method 0: orig, works only without pbc: + !thicknessSum = sshEdge + refBottomDepthTopOfCell(maxLevelEdgeTop(iEdge)+1) + + ! method 1, matches method 0 without pbcs, works with pbcs. + thicknessSum = sshEdge + min(bottomDepth(cell1), bottomDepth(cell2)) + + ! method 2: may be better than method 1. + ! take average of full thickness at two neighboring cells + !thicknessSum = sshEdge + 0.5 *( bottomDepth(cell1) & + ! + bottomDepth(cell2) ) + + flux = ((1.0-config_btr_gam1_velWt1) * normalBarotropicVelocitySubcycleCur(iEdge) & + + config_btr_gam1_velWt1 * normalBarotropicVelocitySubcycleNew(iEdge)) & + * thicknessSum + + barotropicThicknessFlux(iEdge) = barotropicThicknessFlux(iEdge) + barotropicThicknessFlux_coeff * flux + end do + + ! SSHnew = SSHold + dt/J*(-div(Flux)) + do iCell = 1, nCells + sshSubcycleNew(iCell) = sshSubcycleCur(iCell) + dt / config_n_btr_subcycles * sshTend(iCell) / areaCell(iCell) + end do + + block => block % next + end do ! block + + ! boundary update on SSHnew + call mpas_timer_start("se halo ssh", .false., timer_halo_ssh) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + + call mpas_pool_get_field(statePool, 'sshSubcycle', sshSubcycleField, newBtrSubcycleTime) + call mpas_dmpar_exch_halo_field(sshSubcycleField) + call mpas_timer_stop("se halo ssh", timer_halo_ssh) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Barotropic subcycle: VELOCITY CORRECTOR STEP + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do BtrCorIter = 1, config_n_btr_cor_iter + uPerpTime = newBtrSubcycleTime + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleCur, oldBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'sshSubcycle', sshSubcycleCur, oldBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'sshSubcycle', sshSubcycleNew, newBtrSubcycleTime) + + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(meshPool, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + + call mpas_pool_get_array(diagnosticsPool, 'barotropicForcing', barotropicForcing) + + allocate(utemp(nEdges+1)) + + uTemp(:) = normalBarotropicVelocitySubcycleNew(:) + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! Compute the barotropic Coriolis term, -f*uPerp + CoriolisTerm = 0.0 + do i = 1, nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(i,iEdge) + CoriolisTerm = CoriolisTerm + weightsOnEdge(i,iEdge) & + !* normalBarotropicVelocitySubcycleNew(eoe) & + * uTemp(eoe) * fEdge(eoe) + end do + + ! In this final solve for velocity, SSH is a linear + ! combination of SSHold and SSHnew. + sshCell1 = (1-config_btr_gam2_SSHWt1) * sshSubcycleCur(cell1) + config_btr_gam2_SSHWt1 * sshSubcycleNew(cell1) + sshCell2 = (1-config_btr_gam2_SSHWt1) * sshSubcycleCur(cell2) + config_btr_gam2_SSHWt1 * sshSubcycleNew(cell2) + + ! normalBarotropicVelocityNew = normalBarotropicVelocityOld + dt/J*(-f*normalBarotropicVelocityoldPerp - g*grad(SSH) + G) + normalBarotropicVelocitySubcycleNew(iEdge) = (normalBarotropicVelocitySubcycleCur(iEdge) & + + dt / config_n_btr_subcycles *(CoriolisTerm - gravity *(sshCell2 - sshCell1) / dcEdge(iEdge) & + + barotropicForcing(iEdge))) * edgeMask(1,iEdge) + end do + deallocate(uTemp) + + block => block % next + end do ! block + + ! boundary update on normalBarotropicVelocityNew + call mpas_timer_start("se halo normalBarotropicVelocity", .false., timer_halo_normalBarotropicVelocity) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + + call mpas_pool_get_field(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleField, newBtrSubcycleTime) + + call mpas_dmpar_exch_halo_field(normalBarotropicVelocitySubcycleField) + call mpas_timer_stop("se halo normalBarotropicVelocity", timer_halo_normalBarotropicVelocity) + end do !do BtrCorIter=1,config_n_btr_cor_iter + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Barotropic subcycle: SSH CORRECTOR STEP + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (config_btr_solve_SSH2) then + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_array(tendPool, 'ssh', sshTend) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'refBottomDepthTopOfCell', refBottomDepthTopOfCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + + call mpas_pool_get_array(statePool, 'sshSubcycle', sshSubcycleCur, oldBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'sshSubcycle', sshSubcycleNew, newBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleCur, oldBtrSubcycleTime) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) + + call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) + + sshTend(:) = 0.0 + + ! config_btr_gam3_velWt2 sets the forward weighting of velocity in the SSH computation + ! config_btr_gam3_velWt2= 1 flux = normalBarotropicVelocityNew*H + ! config_btr_gam3_velWt2=0.5 flux = 1/2*(normalBarotropicVelocityNew+normalBarotropicVelocityOld)*H + ! config_btr_gam3_velWt2= 0 flux = normalBarotropicVelocityOld*H + + do iCell = 1, nCells + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! SSH is a linear combination of SSHold and SSHnew. + sshCell1 = (1-config_btr_gam2_SSHWt1)* sshSubcycleCur(cell1) & + + config_btr_gam2_SSHWt1 * sshSubcycleNew(cell1) + sshCell2 = (1-config_btr_gam2_SSHWt1)* sshSubcycleCur(cell2) & + + config_btr_gam2_SSHWt1 * sshSubcycleNew(cell2) + + sshEdge = 0.5 * (sshCell1 + sshCell2) + + ! method 0: orig, works only without pbc: + !thicknessSum = sshEdge + refBottomDepthTopOfCell(maxLevelEdgeTop(iEdge)+1) + + ! method 1, matches method 0 without pbcs, works with pbcs. + thicknessSum = sshEdge + min(bottomDepth(cell1), bottomDepth(cell2)) + + ! method 2: may be better than method 1. + ! take average of full thickness at two neighboring cells + !thicknessSum = sshEdge + 0.5 *( bottomDepth(cell1) + bottomDepth (cell2) ) + + flux = ((1.0-config_btr_gam3_velWt2) * normalBarotropicVelocitySubcycleCur(iEdge) & + + config_btr_gam3_velWt2 * normalBarotropicVelocitySubcycleNew(iEdge)) & + * thicknessSum + + sshTend(iCell) = sshTend(iCell) + edgeSignOnCell(i, iCell) * flux & + * dvEdge(iEdge) + + end do + end do + + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! SSH is a linear combination of SSHold and SSHnew. + sshCell1 = (1-config_btr_gam2_SSHWt1)* sshSubcycleCur(cell1) + config_btr_gam2_SSHWt1 * sshSubcycleNew(cell1) + sshCell2 = (1-config_btr_gam2_SSHWt1)* sshSubcycleCur(cell2) + config_btr_gam2_SSHWt1 * sshSubcycleNew(cell2) + sshEdge = 0.5 * (sshCell1 + sshCell2) + + ! method 0: orig, works only without pbc: + !thicknessSum = sshEdge + refBottomDepthTopOfCell(maxLevelEdgeTop(iEdge)+1) + + ! method 1, matches method 0 without pbcs, works with pbcs. + thicknessSum = sshEdge + min(bottomDepth(cell1), bottomDepth(cell2)) + + ! method 2, better, I think. + ! take average of full thickness at two neighboring cells + !thicknessSum = sshEdge + 0.5 *( bottomDepth(cell1) + bottomDepth(cell2) ) + + flux = ((1.0-config_btr_gam3_velWt2) * normalBarotropicVelocitySubcycleCur(iEdge) & + + config_btr_gam3_velWt2 * normalBarotropicVelocitySubcycleNew(iEdge)) & + * thicknessSum + + barotropicThicknessFlux(iEdge) = barotropicThicknessFlux(iEdge) + flux + end do + + ! SSHnew = SSHold + dt/J*(-div(Flux)) + do iCell = 1, nCells + sshSubcycleNew(iCell) = sshSubcycleCur(iCell) & + + dt / config_n_btr_subcycles * sshTend(iCell) / areaCell(iCell) + end do + + block => block % next + end do ! block + + ! boundary update on SSHnew + call mpas_timer_start("se halo ssh", .false., timer_halo_ssh) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + + call mpas_pool_get_field(statePool, 'sshSubcycle', sshSubcycleField) + + call mpas_dmpar_exch_halo_field(sshSubcycleField) + call mpas_timer_stop("se halo ssh", timer_halo_ssh) + endif ! config_btr_solve_SSH2 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Barotropic subcycle: Accumulate running sums, advance timestep pointers + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) + + ! normalBarotropicVelocityNew = normalBarotropicVelocityNew + normalBarotropicVelocitySubcycleNEW + ! This accumulates the sum. + ! If the Barotropic Coriolis iteration is limited to one, this could + ! be merged with the above code. + do iEdge = 1, nEdges + normalBarotropicVelocityNew(iEdge) = normalBarotropicVelocityNew(iEdge) + normalBarotropicVelocitySubcycleNew(iEdge) + end do ! iEdge + block => block % next + end do ! block + + ! advance time pointers + oldBtrSubcycleTime = mod(oldBtrSubcycleTime,2)+1 + newBtrSubcycleTime = mod(newBtrSubcycleTime,2)+1 + + end do ! j=1,config_n_btr_subcycles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! END Barotropic subcycle loop + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Normalize Barotropic subcycle sums: ssh, normalBarotropicVelocity, and F + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) + + call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) + + do iEdge = 1, nEdges + barotropicThicknessFlux(iEdge) = barotropicThicknessFlux(iEdge) & + / (config_n_btr_subcycles * config_btr_subcycle_loop_factor) + + normalBarotropicVelocityNew(iEdge) = normalBarotropicVelocityNew(iEdge) & + / (config_n_btr_subcycles * config_btr_subcycle_loop_factor + 1) + end do + + block => block % next + end do ! block + + + ! boundary update on F + call mpas_timer_start("se halo F", .false., timer_halo_f) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_field(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFluxField) + + call mpas_dmpar_exch_halo_field(barotropicThicknessFluxField) + call mpas_timer_stop("se halo F", timer_halo_f) + + + ! Check that you can compute SSH using the total sum or the individual increments + ! over the barotropic subcycles. + ! efficiency: This next block of code is really a check for debugging, and can + ! be removed later. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityNew, 2) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + + allocate(uTemp(nVertLevels)) + + ! Correction velocity normalVelocityCorrection = (Flux - Sum(h u*))/H + ! or, for the full latex version: + !{\bf u}^{corr} = \left( {\overline {\bf F}} + ! - \sum_{k=1}^{N^{edge}} h_{k,*}^{edge} {\bf u}_k^{avg} \right) + ! \left/ \sum_{k=1}^{N^{edge}} h_{k,*}^{edge} \right. + + if (config_vel_correction) then + useVelocityCorrection = 1 + else + useVelocityCorrection = 0 + endif + + do iEdge = 1, nEdges + + ! velocity for normalVelocityCorrectionection is normalBarotropicVelocity + normalBaroclinicVelocity + uBolus +!mrp note: in QC version, there is an if (config_use_standardGM) on adding normalGMBolusVelocity +! I think it is not needed because normalGMBolusVelocity=0 when GM not on. + uTemp(:) = normalBarotropicVelocityNew(iEdge) + normalBaroclinicVelocityNew(:,iEdge) + normalGMBolusVelocity(:,iEdge) + + ! thicknessSum is initialized outside the loop because on land boundaries + ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a + ! nonzero value to avoid a NaN. + normalThicknessFluxSum = layerThicknessEdge(1,iEdge) * uTemp(1) + thicknessSum = layerThicknessEdge(1,iEdge) + + do k = 2, maxLevelEdgeTop(iEdge) + normalThicknessFluxSum = normalThicknessFluxSum + layerThicknessEdge(k,iEdge) * uTemp(k) + thicknessSum = thicknessSum + layerThicknessEdge(k,iEdge) + enddo + + normalVelocityCorrection = useVelocityCorrection*(( barotropicThicknessFlux(iEdge) - normalThicknessFluxSum)/thicknessSum) + + do k = 1, nVertLevels + + ! normalTransportVelocity = normalBarotropicVelocity + normalBaroclinicVelocity + normalGMBolusVelocity + normalVelocityCorrection + ! This is u used in advective terms for layerThickness and tracers + ! in tendency calls in stage 3. +!mrp note: in QC version, there is an if (config_use_standardGM) on adding normalGMBolusVelocity +! I think it is not needed because normalGMBolusVelocity=0 when GM not on. + normalTransportVelocity(k,iEdge) & + = edgeMask(k,iEdge) & + *( normalBarotropicVelocityNew(iEdge) + normalBaroclinicVelocityNew(k,iEdge) & + + normalGMBolusVelocity(k,iEdge) + normalVelocityCorrection ) + enddo + + end do ! iEdge + + deallocate(uTemp) + + block => block % next + end do ! block + + endif ! split_explicit + + call mpas_timer_stop("se btr vel", timer_btr_vel) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Stage 3: Tracer, density, pressure, vertical velocity prediction + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Thickness tendency computations and thickness halo updates are completed before tracer + ! tendency computations to allow monotonic advection. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'ssh', sshCur, 1) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) + + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'vertAleTransportTop', vertAleTransportTop) + + ! compute vertAleTransportTop. Use normalTransportVelocity for advection of layerThickness and tracers. + ! Use time level 1 values of layerThickness and layerThicknessEdge because + ! layerThickness has not yet been computed for time level 2. + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + layerThicknessCur, layerThicknessEdge, normalTransportVelocity, & + sshCur, highFreqThicknessNew, dt, vertAleTransportTop, err) + + call ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool) + + block => block % next + end do + + ! update halo for thickness tendencies + call mpas_timer_start("se halo thickness", .false., timer_halo_thickness) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + + call mpas_pool_get_field(tendPool, 'layerThickness', layerThicknessField) + + call mpas_dmpar_exch_halo_field(layerThicknessField) + call mpas_timer_stop("se halo thickness", timer_halo_thickness) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, meshPool, scratchPool, dt, 2) + + block => block % next + end do + + ! update halo for tracer tendencies + call mpas_timer_start("se halo tracers", .false., timer_halo_tracers) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + + call mpas_pool_get_field(tendPool, 'tracers', tracersField) + + call mpas_dmpar_exch_halo_field(tracersField) + call mpas_timer_stop("se halo tracers", timer_halo_tracers) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + + call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceCur, 1) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceNew, 2) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityNew, 2) + + call mpas_pool_get_array(tendPool, 'tracers', tracersTend) + call mpas_pool_get_array(tendPool, 'layerThickness', layerThicknessTend) + call mpas_pool_get_array(tendPool, 'normalVelocity', normalVelocityTend) + call mpas_pool_get_array(tendPool, 'highFreqThickness', highFreqThicknessTend) + call mpas_pool_get_array(tendPool, 'lowFreqDivergence', lowFreqDivergenceTend) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! If iterating, reset variables for next iteration + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (split_explicit_step < config_n_ts_iter) then + + ! Get indices for dynamic tracers (Includes T&S). + call mpas_pool_get_dimension(statePool, 'dynamics_start', startIndex) + call mpas_pool_get_dimension(statePool, 'dynamics_end', endIndex) + + ! Only need T & S for earlier iterations, + ! then all the tracers needed the last time through. + do iCell = 1, nCells + ! sshNew is a pointer, defined above. + do k = 1, maxLevelCell(iCell) + + ! this is h_{n+1} + temp_h = layerThicknessCur(k,iCell) + dt * layerThicknessTend(k,iCell) + + ! this is h_{n+1/2} + layerThicknessNew(k,iCell) = 0.5*( layerThicknessCur(k,iCell) + temp_h) + + do i = startIndex, endIndex + ! This is Phi at n+1 + temp = ( tracersCur(i,k,iCell) * layerThicknessCur(k,iCell) + dt * tracersTend(i,k,iCell)) / temp_h + + ! This is Phi at n+1/2 + tracersNew(i,k,iCell) = 0.5 * ( tracersCur(i,k,iCell) + temp ) + end do + end do + end do ! iCell + + if (config_use_freq_filtered_thickness) then + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + + ! h^{hf}_{n+1} was computed in Stage 1 + + ! this is h^{hf}_{n+1/2} + highFreqThicknessnew(k,iCell) = 0.5 * (highFreqThicknessCur(k,iCell) + highFreqThicknessNew(k,iCell)) + + ! this is D^{lf}_{n+1} + temp = lowFreqDivergenceCur(k,iCell) & + + dt * lowFreqDivergenceTend(k,iCell) + + ! this is D^{lf}_{n+1/2} + lowFreqDivergenceNew(k,iCell) = 0.5 * (lowFreqDivergenceCur(k,iCell) + temp) + end do + end do + end if + + do iEdge = 1, nEdges + + do k = 1, nVertLevels + + ! u = normalBarotropicVelocity + normalBaroclinicVelocity + ! here normalBaroclinicVelocity is at time n+1/2 + ! This is u used in next iteration or step + normalVelocityNew(k,iEdge) = edgeMask(k,iEdge) * ( normalBarotropicVelocityNew(iEdge) + normalBaroclinicVelocityNew(k,iEdge) ) + + enddo + + end do ! iEdge + + ! Efficiency note: We really only need this to compute layerThicknessEdge, density, pressure, and SSH + ! in this diagnostics solve. + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! If large iteration complete, compute all variables at time n+1 + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + elseif (split_explicit_step == config_n_ts_iter) then + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + + ! this is h_{n+1} + layerThicknessNew(k,iCell) = layerThicknessCur(k,iCell) + dt * layerThicknessTend(k,iCell) + + ! This is Phi at n+1 + do i = 1, num_tracers + tracersNew(i,k,iCell) = (tracersCur(i,k,iCell) * layerThicknessCur(k,iCell) + dt * tracersTend(i,k,iCell) ) & + / layerThicknessNew(k,iCell) + + enddo + end do + end do + + if (config_use_freq_filtered_thickness) then + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + + ! h^{hf}_{n+1} was computed in Stage 1 + + ! this is D^{lf}_{n+1} + lowFreqDivergenceNew(k,iCell) = lowFreqDivergenceCur(k,iCell) + dt * lowFreqDivergenceTend(k,iCell) + end do + end do + end if + + ! Recompute final u to go on to next step. + ! u_{n+1} = normalBarotropicVelocity_{n+1} + normalBaroclinicVelocity_{n+1} + ! Right now normalBaroclinicVelocityNew is at time n+1/2, so back compute to get normalBaroclinicVelocity at time n+1 + ! using normalBaroclinicVelocity_{n+1/2} = 1/2*(normalBaroclinicVelocity_n + u_Bcl_{n+1}) + ! so the following lines are + ! u_{n+1} = normalBarotropicVelocity_{n+1} + 2*normalBaroclinicVelocity_{n+1/2} - normalBaroclinicVelocity_n + ! note that normalBaroclinicVelocity is recomputed at the beginning of the next timestep due to Imp Vert mixing, + ! so normalBaroclinicVelocity does not have to be recomputed here. + + do iEdge = 1, nEdges + do k = 1, maxLevelEdgeTop(iEdge) + normalVelocityNew(k,iEdge) = normalBarotropicVelocityNew(iEdge) + 2 * normalBaroclinicVelocityNew(k,iEdge) - normalBaroclinicVelocityCur(k,iEdge) + end do + end do ! iEdges + + endif ! split_explicit_step + + block => block % next + end do + + + + end do ! split_explicit_step = 1, config_n_ts_iter + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! END large iteration loop + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Perform Sea Ice Formation Adjustment + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + + call mpas_pool_get_array(forcingPool, 'seaIceEnergy', seaIceEnergy) + + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, layerThicknessNew, & + tracersNew, seaIceEnergy, err) + block => block % next + end do + + call mpas_timer_start("se implicit vert mix") + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + + ! 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 density, layerThicknessEdge, and kineticEnergyCell 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. + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + + ! Compute normalGMBolusVelocity; it will be added to the baroclinic modes in Stage 2 above. + if (config_use_standardGM) then + call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) + end if + call ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, 2) + + 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_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + + call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocityField, 2) + call mpas_pool_get_field(statePool, 'tracers', tracersField, 2) + + call mpas_dmpar_exch_halo_field(normalVelocityField) + call mpas_dmpar_exch_halo_field(tracersField) + call mpas_timer_stop("se implicit vert mix halos") + + call mpas_timer_stop("se implicit vert mix") + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'average', averagePool) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'velocityX', velocityX) + call mpas_pool_get_array(diagnosticsPool, 'velocityY', velocityY) + call mpas_pool_get_array(diagnosticsPool, 'velocityZ', velocityZ) + call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) + call mpas_pool_get_array(diagnosticsPool, 'gradSSH', gradSSH) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHX', gradSSHX) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHY', gradSSHY) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHZ', gradSSHZ) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHZonal', gradSSHZonal) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHMeridional', gradSSHMeridional) + + call mpas_pool_get_array(diagnosticsPool, 'surfaceVelocity', surfaceVelocity) + call mpas_pool_get_array(diagnosticsPool, 'SSHGradient', SSHGradient) + + call mpas_pool_get_dimension(diagnosticsPool, 'index_surfaceVelocityZonal', indexSurfaceVelocityZonal) + call mpas_pool_get_dimension(diagnosticsPool, 'index_surfaceVelocityMeridional', indexSurfaceVelocityMeridional) + call mpas_pool_get_dimension(diagnosticsPool, 'index_SSHGradientZonal', indexSSHGradientZonal) + call mpas_pool_get_dimension(diagnosticsPool, 'index_SSHGradientMeridional', indexSSHGradientMeridional) + + if (config_prescribe_velocity) then + normalVelocityNew(:,:) = normalVelocityCur(:,:) + end if + + if (config_prescribe_thickness) then + layerThicknessNew(:,:) = layerThicknessCur(:,:) + end if + + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + + ! Compute normalGMBolusVelocity; it will be added to normalVelocity in Stage 2 of the next cycle. + if (config_use_standardGM) then + call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) + end if + + call mpas_reconstruct(meshPool, normalVelocityNew, & + velocityX, velocityY, velocityZ, & + velocityZonal, velocityMeridional & + ) + + call mpas_reconstruct(meshPool, gradSSH, & + gradSSHX, gradSSHY, gradSSHZ, & + gradSSHZonal, gradSSHMeridional & + ) + + surfaceVelocity(indexSurfaceVelocityZonal, :) = velocityZonal(1, :) + surfaceVelocity(indexSurfaceVelocityMeridional, :) = velocityMeridional(1, :) + + SSHGradient(indexSSHGradientZonal, :) = gradSSHZonal(1, :) + SSHGradient(indexSSHGradientMeridional, :) = gradSSHMeridional(1, :) + + call ocn_time_average_accumulate(averagePool, statePool, diagnosticsPool, 2) + call ocn_time_average_coupled_accumulate(diagnosticsPool, forcingPool) + + if (config_use_standardGM) then + call ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) + end if + + block => block % next + end do + + call mpas_timer_stop("se timestep", timer_main) + + deallocate(n_bcl_iter) + + end subroutine ocn_time_integrator_split!}}} + +end module ocn_time_integration_split + +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_diagnostics.F b/src/core_ocean/mpas_ocn_diagnostics.F deleted file mode 100644 index 6afd65049b..0000000000 --- a/src/core_ocean/mpas_ocn_diagnostics.F +++ /dev/null @@ -1,1044 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_diagnostics -! -!> \brief MPAS ocean diagnostics driver -!> \author Mark Petersen -!> \date 23 September 2011 -!> \details -!> This module contains the routines for computing -!> diagnostic variables, and other quantities such as vertTransportVelocityTop. -! -!----------------------------------------------------------------------- - -module ocn_diagnostics - - use mpas_grid_types - use mpas_configure - use mpas_constants - use mpas_timer - - use ocn_gm - use ocn_equation_of_state - use ocn_thick_ale - - implicit none - private - save - - type (timer_node), pointer :: diagEOSTimer - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_diagnostic_solve, & - ocn_vert_transport_velocity_top, & - ocn_fuperp, & - ocn_filter_btr_mode_vel, & - ocn_filter_btr_mode_tend_vel, & - 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 -!> \details -!> This routine computes the diagnostic variables for the ocean -! -!----------------------------------------------------------------------- - - subroutine ocn_diagnostic_solve(dt, state, forcing, mesh, diagnostics, scratch)!{{{ - - real (kind=RKIND), intent(in) :: dt !< Input: Time step - type (state_type), intent(inout) :: state !< Input/Output: State information - type (forcing_type), intent(in) :: forcing !< Input: Forcing information - type (mesh_type), intent(in) :: mesh !< Input: mesh information - type (diagnostics_type), intent(inout) :: diagnostics !< Input/Output: diagnostic fields derived from State - type (scratch_type), intent(inout) :: scratch !< Input: scratch variables - - 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, layerThicknessVertex, 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, layerThicknessEdge, layerThickness, normalVelocity, tangentialVelocity, pressure,& - circulation, kineticEnergyCell, montgomeryPotential, vertTransportVelocityTop, zMid, zTop, divergence, & - relativeVorticity, relativeVorticityCell, & - normalizedPlanetaryVorticityEdge, normalizedPlanetaryVorticityVertex, & - normalizedRelativeVorticityEdge, normalizedRelativeVorticityVertex, normalizedRelativeVorticityCell, & - density, displacedDensity, potentialDensity, temperature, salinity, kineticEnergyVertex, kineticEnergyVertexOnCells, uBolusGM, uTransport, & - vertVelocityTop, BruntVaisalaFreqTop, & - vorticityGradientNormalComponent, vorticityGradientTangentialComponent - real (kind=RKIND), dimension(:,:,:), pointer :: tracers, derivTwo - character :: c1*6 - - real (kind=RKIND), dimension(:,:), pointer :: tracersSurfaceValue ! => diagnostics % tracersSurfaceValue % array - - layerThickness => state % layerThickness % array - normalVelocity => state % normalVelocity % array - tracers => state % tracers % array - ssh => state % ssh % array - - zMid => diagnostics % zMid % array - zTop => diagnostics % zTop % array - divergence => diagnostics % divergence % array - circulation => diagnostics % circulation % array - relativeVorticity => diagnostics % relativeVorticity % array - relativeVorticityCell => diagnostics % relativeVorticityCell % array - normalizedPlanetaryVorticityEdge => diagnostics % normalizedPlanetaryVorticityEdge % array - normalizedRelativeVorticityEdge => diagnostics % normalizedRelativeVorticityEdge % array - normalizedRelativeVorticityCell => diagnostics % normalizedRelativeVorticityCell % array - density => diagnostics % density % array - displacedDensity => diagnostics % displacedDensity % array - potentialDensity => diagnostics % potentialDensity % array - montgomeryPotential => diagnostics % montgomeryPotential % array - pressure => diagnostics % pressure % array - BruntVaisalaFreqTop => diagnostics % BruntVaisalaFreqTop % array - tangentialVelocity => diagnostics % tangentialVelocity % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - kineticEnergyCell => diagnostics % kineticEnergyCell % array - vertVelocityTop => diagnostics % vertVelocityTop % array - uBolusGM => diagnostics % uBolusGM % array - uTransport => diagnostics % uTransport % array - - weightsOnEdge => mesh % weightsOnEdge % array - kiteAreasOnVertex => mesh % kiteAreasOnVertex % array - cellsOnEdge => mesh % cellsOnEdge % array - cellsOnVertex => mesh % cellsOnVertex % array - verticesOnEdge => mesh % verticesOnEdge % array - nEdgesOnCell => mesh % nEdgesOnCell % array - nEdgesOnEdge => mesh % nEdgesOnEdge % array - edgesOnCell => mesh % edgesOnCell % array - edgesOnEdge => mesh % edgesOnEdge % array - edgesOnVertex => mesh % edgesOnVertex % array - dcEdge => mesh % dcEdge % array - dvEdge => mesh % dvEdge % array - areaCell => mesh % areaCell % array - areaTriangle => mesh % areaTriangle % array - bottomDepth => mesh % bottomDepth % array - fVertex => mesh % fVertex % array - derivTwo => mesh % derivTwo % array - maxLevelCell => mesh % maxLevelCell % array - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - maxLevelEdgeBot => mesh % maxLevelEdgeBot % array - maxLevelVertexBot => mesh % maxLevelVertexBot % array - kiteIndexOnCell => mesh % kiteIndexOnCell % array - verticesOnCell => mesh % verticesOnCell % array - - seaSurfacePressure => forcing % seaSurfacePressure % array - - nCells = mesh % nCells - nEdges = mesh % nEdges - nVertices = mesh % nVertices - nVertLevels = mesh % nVertLevels - vertexDegree = mesh % vertexDegree - - boundaryCell => mesh % boundaryCell % array - - edgeSignOnVertex => mesh % edgeSignOnVertex % array - edgeSignOnCell => mesh % edgeSignOnCell % array - - tracersSurfaceValue => diagnostics % tracersSurfaceValue % array(:,:) - - ! - ! Compute height on cell edges at velocity locations - ! Namelist options control the order of accuracy of the reconstructed layerThicknessEdge value - ! - - ! initialize layerThicknessEdge to avoid divide by zero and NaN problems. - layerThicknessEdge = -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) - layerThicknessEdge(k,iEdge) = 0.5 * (layerThickness(k,cell1) + layerThickness(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. - ! - normalVelocity(:,nEdges+1) = -1e34 - layerThickness(:,nCells+1) = -1e34 - tracers(state % index_temperature,:,nCells+1) = -1e34 - tracers(state % index_salinity,:,nCells+1) = -1e34 - - circulation(:,:) = 0.0 - relativeVorticity(:,:) = 0.0 - divergence(:,:) = 0.0 - vertVelocityTop(:,:)=0.0 - kineticEnergyCell(:,:) = 0.0 - tangentialVelocity(:,:) = 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) * normalVelocity(k, iEdge) - - circulation(k, iVertex) = circulation(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp - relativeVorticity(k, iVertex) = relativeVorticity(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp * invAreaTri1 - end do - end do - end do - - relativeVorticityCell(:,:) = 0.0 - 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) - relativeVorticityCell(k, iCell) = relativeVorticityCell(k, iCell) + kiteAreasOnVertex(j, iVertex) * relativeVorticity(k, iVertex) * invAreaCell1 - 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) * normalVelocity(k, iEdge) * invAreaCell1 - - divergence(k, iCell) = divergence(k, iCell) - edgeSignOnCell(i, iCell) * r_tmp - div_hu(k) = div_hu(k) - layerThicknessEdge(k, iEdge) * edgeSignOnCell(i, iCell) * r_tmp - kineticEnergyCell(k, iCell) = kineticEnergyCell(k, iCell) + 0.25 * r_tmp * dcEdge(iEdge) * normalVelocity(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) - do k = 1,maxLevelEdgeTop(iEdge) - tangentialVelocity(k,iEdge) = tangentialVelocity(k,iEdge) + weightsOnEdge(i,iEdge) * normalVelocity(k, eoe) - end do - end do - end do - - ! - ! Compute kinetic energy - ! - call mpas_allocate_scratch_field(scratch % kineticEnergyVertex, .true.) - call mpas_allocate_scratch_field(scratch % kineticEnergyVertexOnCells, .true.) - kineticEnergyVertex => scratch % kineticEnergyVertex % array - kineticEnergyVertexOnCells => scratch % kineticEnergyVertexOnCells % array - kineticEnergyVertex(:,:) = 0.0; - kineticEnergyVertexOnCells(:,:) = 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 - kineticEnergyVertex(k, iVertex) = kineticEnergyVertex(k, iVertex) + r_tmp * normalVelocity(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 - kineticEnergyVertexOnCells(k, iCell) = kineticEnergyVertexOnCells(k, iCell) + kiteAreasOnVertex(j, iVertex) * kineticEnergyVertex(k, iVertex) * invAreaCell1 - end do - end do - end do - - ! - ! Compute kinetic energy in each cell by blending kineticEnergyCell and kineticEnergyVertexOnCells - ! - do iCell=1,nCells*ke_vertex_flag - do k=1,nVertLevels - kineticEnergyCell(k,iCell) = 5.0/8.0*kineticEnergyCell(k,iCell) + 3.0/8.0*kineticEnergyVertexOnCells(k,iCell) - end do - end do - - call mpas_deallocate_scratch_field(scratch % kineticEnergyVertex, .true.) - call mpas_deallocate_scratch_field(scratch % kineticEnergyVertexOnCells, .true.) - - - ! - ! Compute normalized relative and planetary vorticity - ! - call mpas_allocate_scratch_field(scratch % normalizedRelativeVorticityVertex, .true.) - call mpas_allocate_scratch_field(scratch % normalizedPlanetaryVorticityVertex, .true.) - normalizedPlanetaryVorticityVertex => scratch % normalizedPlanetaryVorticityVertex % array - normalizedRelativeVorticityVertex => scratch % normalizedRelativeVorticityVertex % array - do iVertex = 1,nVertices - invAreaTri1 = 1.0 / areaTriangle(iVertex) - do k=1,maxLevelVertexBot(iVertex) - layerThicknessVertex = 0.0 - do i=1,vertexDegree - layerThicknessVertex = layerThicknessVertex + layerThickness(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex) - end do - layerThicknessVertex = layerThicknessVertex * invAreaTri1 - - normalizedRelativeVorticityVertex(k,iVertex) = relativeVorticity(k,iVertex) / layerThicknessVertex - normalizedPlanetaryVorticityVertex(k,iVertex) = fVertex(iVertex) / layerThicknessVertex - end do - end do - - normalizedRelativeVorticityEdge(:,:) = 0.0 - normalizedPlanetaryVorticityEdge(:,:) = 0.0 - do iEdge = 1, nEdges - vertex1 = verticesOnEdge(1, iEdge) - vertex2 = verticesOnEdge(2, iEdge) - do k = 1, maxLevelEdgeBot(iEdge) - normalizedRelativeVorticityEdge(k, iEdge) = 0.5 * (normalizedRelativeVorticityVertex(k, vertex1) + normalizedRelativeVorticityVertex(k, vertex2)) - normalizedPlanetaryVorticityEdge(k, iEdge) = 0.5 * (normalizedPlanetaryVorticityVertex(k, vertex1) + normalizedPlanetaryVorticityVertex(k, vertex2)) - end do - end do - - normalizedRelativeVorticityCell(:,:) = 0.0 - 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) - normalizedRelativeVorticityCell(k, iCell) = normalizedRelativeVorticityCell(k, iCell) & - + kiteAreasOnVertex(j, iVertex) * normalizedRelativeVorticityVertex(k, iVertex) * invAreaCell1 - end do - end do - end do - - ! Diagnostics required for the Anticipated Potential Vorticity Method (apvm). - if (config_apvm_scale_factor>1e-10) then - - call mpas_allocate_scratch_field(scratch % vorticityGradientNormalComponent, .true.) - call mpas_allocate_scratch_field(scratch % vorticityGradientTangentialComponent, .true.) - vorticityGradientNormalComponent => scratch % vorticityGradientNormalComponent % array - vorticityGradientTangentialComponent => scratch % vorticityGradientTangentialComponent % array - 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 the gradient for all edges bounding real cells ) - do k=1,maxLevelEdgeTop(iEdge) - vorticityGradientNormalComponent(k,iEdge) = & - (normalizedRelativeVorticityCell(k,cell2) - normalizedRelativeVorticityCell(k,cell1)) * invLength - enddo - - invLength = 1.0 / dvEdge(iEdge) - ! Compute gradient of PV in the tangent direction - ! ( this computes the gradient at all edges bounding real cells and distance-1 ghost cells ) - do k = 1,maxLevelEdgeBot(iEdge) - vorticityGradientTangentialComponent(k,iEdge) = & - (normalizedRelativeVorticityVertex(k,vertex2) - normalizedRelativeVorticityVertex(k,vertex1)) * invLength - enddo - - enddo - - ! - ! Modify PV edge with upstream bias. - ! - do iEdge = 1,nEdges - do k = 1,maxLevelEdgeBot(iEdge) - normalizedRelativeVorticityEdge(k,iEdge) = normalizedRelativeVorticityEdge(k,iEdge) & - - config_apvm_scale_factor * dt * & - ( normalVelocity(k,iEdge) * vorticityGradientNormalComponent(k,iEdge) & - + tangentialVelocity(k,iEdge) * vorticityGradientTangentialComponent(k,iEdge) ) - enddo - enddo - call mpas_deallocate_scratch_field(scratch % vorticityGradientNormalComponent, .true.) - call mpas_deallocate_scratch_field(scratch % vorticityGradientTangentialComponent, .true.) - - endif - call mpas_deallocate_scratch_field(scratch % normalizedRelativeVorticityVertex, .true.) - call mpas_deallocate_scratch_field(scratch % normalizedPlanetaryVorticityVertex, .true.) - - ! - ! equation of state - ! - call mpas_timer_start("equation of state", .false., diagEOSTimer) - - ! compute in-place density - call ocn_equation_of_state_density(state, diagnostics, mesh, 0, 'relative', density, err) - - ! compute potentialDensity, the density displaced adiabatically to the mid-depth of top layer. - call ocn_equation_of_state_density(state, diagnostics, mesh, 1, 'absolute', potentialDensity, err) - - ! compute displacedDensity, density displaced adiabatically to the mid-depth one layer deeper. - ! That is, layer k has been displaced to the depth of layer k+1. - call ocn_equation_of_state_density(state, diagnostics, mesh, 1, 'relative', displacedDensity, err) - - call mpas_timer_stop("equation of state", diagEOSTimer) - - ! - ! Pressure - ! This section must be placed in the code after computing the density. - ! - if (config_pressure_gradient_type.eq.'MontgomeryPotential') then - - ! use Montgomery Potential when layers are isopycnal. - ! However, one may use 'pressure_and_zmid' when layers are isopycnal as well. - ! 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 - ! At top layer it is g*SSH, where SSH may be off by a - ! constant (ie, bottomDepth can be relative to top or bottom) - montgomeryPotential(1,iCell) = gravity & - * (bottomDepth(iCell) + sum(layerThickness(1:nVertLevels,iCell))) - - do k=2,nVertLevels - pTop(k) = pTop(k-1) + density(k-1,iCell)*gravity* layerThickness(k-1,iCell) - - ! from delta M = p delta / density - montgomeryPotential(k,iCell) = montgomeryPotential(k-1,iCell) & - + pTop(k)*(1.0/density(k,iCell) - 1.0/density(k-1,iCell)) - end do - - end do - deallocate(pTop) - - elseif (config_pressure_gradient_type.eq.'pressure_and_zmid') then - - 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) + density(1,iCell)*gravity & - * 0.5*layerThickness(1,iCell) - - do k=2,maxLevelCell(iCell) - pressure(k,iCell) = pressure(k-1,iCell) & - + 0.5*gravity*( density(k-1,iCell)*layerThickness(k-1,iCell) & - + density(k ,iCell)*layerThickness(k ,iCell)) - end do - - ! Compute zMid, the z-coordinate of the middle of the layer. - ! Compute zTop, the z-coordinate of the top of the layer. - ! 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*layerThickness(k,iCell) - zTop(k:nVertLevels,iCell) = -bottomDepth(iCell) + layerThickness(k,iCell) - - do k=maxLevelCell(iCell)-1, 1, -1 - zMid(k,iCell) = zMid(k+1,iCell) & - + 0.5*( layerThickness(k+1,iCell) & - + layerThickness(k ,iCell)) - zTop(k,iCell) = zTop(k+1,iCell) & - + layerThickness(k ,iCell) - end do - - ! copy zTop(1,iCell) into sea-surface height array - ssh(iCell) = zTop(1,iCell) - - end do - - endif - - ! - ! Brunt-Vaisala frequency - ! - coef = -gravity/config_density0 - do iCell=1,nCells - BruntVaisalaFreqTop(1,iCell) = 0.0 - do k=2,maxLevelCell(iCell) - BruntVaisalaFreqTop(k,iCell) = coef * (displacedDensity(k-1,iCell) - density(k,iCell)) & - / (zMid(k-1,iCell) - zMid(k,iCell)) - end do - end do - - ! - ! extrapolate tracer values to ocean surface - ! this eventually be a modelled process - ! at present, just copy k=1 tracer values onto surface values - tracersSurfaceValue(:,:) = tracers(:,1,:) - - ! - ! compute fields used as intent(in) to CVMix/KPP - call computeKPPInputFields(state, forcing, mesh, diagnostics, scratch) - - ! - ! Apply the GM closure as a bolus velocity - ! - if (config_h_kappa .GE. epsilon(0D0)) then - call ocn_gm_compute_uBolus(state, diagnostics, mesh) - else - uBolusGM = 0.0 - end if - -#ifdef MPAS_CESM - do iEdge = 1, mesh % nEdgesSolve - cell1 = cellsOnEdge(1, iEdge) - cell2 = cellsOnEdge(2, iEdge) - - diagnostics % gradSSH % array(1, iEdge) = (ssh(cell2) - ssh(cell1)) / dcEdge(iEdge) - end do -#endif - - end subroutine ocn_diagnostic_solve!}}} - -!*********************************************************************** -! -! routine ocn_vert_transport_velocity_top -! -!> \brief Computes vertical transport -!> \author Mark Petersen -!> \date August 2013 -!> \details -!> This routine computes the vertical transport through the top of each -!> cell. -! -!----------------------------------------------------------------------- - subroutine ocn_vert_transport_velocity_top(mesh, verticalMesh, oldLayerThickness, layerThicknessEdge, & - normalVelocity, oldSSH, newHighFreqThickness, dt, vertTransportVelocityTop, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - type (mesh_type), intent(in) :: & - mesh !< Input: horizonal mesh information - - type (verticalMesh_type), intent(in) :: & - verticalMesh !< Input: vertical mesh information - - real (kind=RKIND), dimension(:,:), intent(in) :: & - oldLayerThickness !< Input: layer thickness at old time - - real (kind=RKIND), dimension(:,:), intent(in) :: & - layerThicknessEdge !< Input: layerThickness interpolated to an edge - - real (kind=RKIND), dimension(:,:), intent(in) :: & - normalVelocity !< Input: transport - - real (kind=RKIND), dimension(:), intent(in) :: & - oldSSH !< Input: sea surface height at old time - - real (kind=RKIND), dimension(:,:), intent(in) :: & - newHighFreqThickness !< Input: high frequency thickness. Alters ALE thickness. - - real (kind=RKIND), intent(in) :: & - dt !< Input: time step - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - real (kind=RKIND), dimension(:,:), intent(out) :: & - vertTransportVelocityTop !< Output: vertical transport at top of cell - - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - integer :: iEdge, iCell, k, i, nCells, nVertLevels - integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, & - maxLevelCell, maxLevelEdgeBot - integer, dimension(:,:), pointer :: edgesOnCell, edgeSignOnCell - - real (kind=RKIND) :: flux, invAreaCell - real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell - real (kind=RKIND), dimension(:), allocatable :: & - div_hu_btr !> barotropic divergence of (thickness*velocity) - real (kind=RKIND), dimension(:,:), allocatable :: & - ALE_Thickness, & !> ALE thickness at new time - div_hu !> divergence of (thickness*velocity) - - err = 0 - - nEdgesOnCell => mesh % nEdgesOnCell % array - areaCell => mesh % areaCell % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnCell => mesh % edgeSignOnCell % array - maxLevelCell => mesh % maxLevelCell % array - maxLevelEdgeBot => mesh % maxLevelEdgeBot % array - dvEdge => mesh % dvEdge % array - - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels - - if (config_vert_coord_movement.eq.'impermeable_interfaces') then - vertTransportVelocityTop=0.0 - return - end if - - allocate(div_hu(nVertLevels,nCells), div_hu_btr(nCells), ALE_Thickness(nVertLevels,nCells)) - - ! - ! thickness-weighted divergence and barotropic divergence - ! - ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3. - do iCell=1,nCells - div_hu(:,iCell) = 0.0 - div_hu_btr(iCell) = 0.0 - invAreaCell = 1.0 / areaCell(iCell) - do i = 1, nEdgesOnCell(iCell) - iEdge = edgesOnCell(i, iCell) - - do k = 1, maxLevelEdgeBot(iEdge) - flux = layerThicknessEdge(k, iEdge) * normalVelocity(k, iEdge) * dvEdge(iEdge) * edgeSignOnCell(i, iCell) * invAreaCell - div_hu(k,iCell) = div_hu(k,iCell) - flux - div_hu_btr(iCell) = div_hu_btr(iCell) - flux - end do - end do - - enddo - - ! - ! Compute desired thickness at new time - ! - call ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreqThickness, dt, ALE_thickness, err) - - ! - ! Vertical transport through layer interfaces - ! - ! Vertical transport through layer interface at top and bottom is zero. - ! Here we are using solving the continuity equation for vertTransportVelocityTop ($w^t$), - ! and using ALE_Thickness for thickness at the new time. - - do iCell=1,nCells - vertTransportVelocityTop(1,iCell) = 0.0 - vertTransportVelocityTop(maxLevelCell(iCell)+1,iCell) = 0.0 - do k=maxLevelCell(iCell),2,-1 - vertTransportVelocityTop(k,iCell) = vertTransportVelocityTop(k+1,iCell) - div_hu(k,iCell) & - - (ALE_Thickness(k,iCell) - oldLayerThickness(k,iCell))/dt - end do - end do - - deallocate(div_hu, div_hu_btr, ALE_Thickness) - - end subroutine ocn_vert_transport_velocity_top!}}} - -!*********************************************************************** -! -! routine ocn_fuperp -! -!> \brief Computes f u_perp -!> \author Mark Petersen -!> \date 23 September 2011 -!> \details -!> This routine computes f u_perp for the ocean -! -!----------------------------------------------------------------------- - - subroutine ocn_fuperp(state, mesh)!{{{ - - type (state_type), intent(inout) :: state !< Input/Output: State information - type (mesh_type), intent(in) :: mesh !< Input: mesh information - - integer :: iEdge, cell1, cell2, eoe, i, j, k - integer :: nEdgesSolve - real (kind=RKIND), dimension(:), pointer :: fEdge - real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, normalVelocity, normalBaroclinicVelocity - type (dm_info) :: dminfo - - integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnEdge - integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge - - call mpas_timer_start("ocn_fuperp") - - normalVelocity => state % normalVelocity % array - normalBaroclinicVelocity => state % normalBaroclinicVelocity % array - weightsOnEdge => mesh % weightsOnEdge % array - fEdge => mesh % fEdge % array - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - cellsOnEdge => mesh % cellsOnEdge % array - nEdgesOnEdge => mesh % nEdgesOnEdge % array - edgesOnEdge => mesh % edgesOnEdge % array - - fEdge => mesh % fEdge % array - - nEdgesSolve = mesh % nEdgesSolve - - ! - ! Put f*normalBaroclinicVelocity^{perp} in u as a work variable - ! - do iEdge=1,nEdgesSolve - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,maxLevelEdgeTop(iEdge) - - normalVelocity(k,iEdge) = 0.0 - do j = 1,nEdgesOnEdge(iEdge) - eoe = edgesOnEdge(j,iEdge) - normalVelocity(k,iEdge) = normalVelocity(k,iEdge) + weightsOnEdge(j,iEdge) * normalBaroclinicVelocity(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_vel -! -!> \brief filters barotropic mode out of the velocity variable. -!> \author Mark Petersen -!> \date 23 September 2011 -!> \details -!> This routine filters barotropic mode out of the velocity variable. -! -!----------------------------------------------------------------------- - subroutine ocn_filter_btr_mode_vel(state, diagnostics, mesh)!{{{ - - type (state_type), intent(inout) :: state !< Input/Output: State information - type (diagnostics_type), intent(in) :: diagnostics !< Input: Diagnostics information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - - integer :: iEdge, k, nEdges - real (kind=RKIND) :: vertSum, normalThicknessFluxSum, thicknessSum - real (kind=RKIND), dimension(:,:), pointer :: layerThicknessEdge, normalVelocity - integer, dimension(:), pointer :: maxLevelEdgeTop - - call mpas_timer_start("ocn_filter_btr_mode_vel") - - normalVelocity => state % normalVelocity % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - nEdges = mesh % nEdges - - do iEdge=1,nEdges - - ! thicknessSum is initialized outside the loop because on land boundaries - ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a - ! nonzero value to avoid a NaN. - normalThicknessFluxSum = layerThicknessEdge(1,iEdge) * normalVelocity(1,iEdge) - thicknessSum = layerThicknessEdge(1,iEdge) - - do k=2,maxLevelEdgeTop(iEdge) - normalThicknessFluxSum = normalThicknessFluxSum + layerThicknessEdge(k,iEdge) * normalVelocity(k,iEdge) - thicknessSum = thicknessSum + layerThicknessEdge(k,iEdge) - enddo - - vertSum = normalThicknessFluxSum/thicknessSum - do k=1,maxLevelEdgeTop(iEdge) - normalVelocity(k,iEdge) = normalVelocity(k,iEdge) - vertSum - enddo - enddo ! iEdge - - call mpas_timer_stop("ocn_filter_btr_mode_vel") - - end subroutine ocn_filter_btr_mode_vel!}}} - -!*********************************************************************** -! -! routine ocn_filter_btr_mode_tend_vel -! -!> \brief ocn_filters barotropic mode out of the velocity tendency -!> \author Mark Petersen -!> \date 23 September 2011 -!> \details -!> This routine filters barotropic mode out of the velocity tendency. -! -!----------------------------------------------------------------------- - subroutine ocn_filter_btr_mode_tend_vel(tend, state, diagnostics, mesh)!{{{ - - type (tend_type), intent(inout) :: tend !< Input/Output: Tendency information - type (state_type), intent(in) :: state !< Input: State information - type (diagnostics_type), intent(in) :: diagnostics !< Input: Diagnostics information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - - integer :: iEdge, k, nEdges - real (kind=RKIND) :: vertSum, normalThicknessFluxSum, thicknessSum - real (kind=RKIND), dimension(:,:), pointer :: layerThicknessEdge, tend_normalVelocity - - integer, dimension(:), pointer :: maxLevelEdgeTop - - call mpas_timer_start("ocn_filter_btr_mode_tend_vel") - - tend_normalVelocity => tend % normalVelocity % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - nEdges = mesh % nEdges - - do iEdge=1,nEdges - - ! thicknessSum is initialized outside the loop because on land boundaries - ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a - ! nonzero value to avoid a NaN. - normalThicknessFluxSum = layerThicknessEdge(1,iEdge) * tend_normalVelocity(1,iEdge) - thicknessSum = layerThicknessEdge(1,iEdge) - - do k=2,maxLevelEdgeTop(iEdge) - normalThicknessFluxSum = normalThicknessFluxSum + layerThicknessEdge(k,iEdge) * tend_normalVelocity(k,iEdge) - thicknessSum = thicknessSum + layerThicknessEdge(k,iEdge) - enddo - - vertSum = normalThicknessFluxSum/thicknessSum - do k=1,maxLevelEdgeTop(iEdge) - tend_normalVelocity(k,iEdge) = tend_normalVelocity(k,iEdge) - vertSum - enddo - enddo ! iEdge - - call mpas_timer_stop("ocn_filter_btr_mode_tend_vel") - - end subroutine ocn_filter_btr_mode_tend_vel!}}} - -!*********************************************************************** -! -! routine ocn_diagnostics_init -! -!> \brief Initializes flags used within diagnostics routines. -!> \author Mark Petersen -!> \date 4 November 2011 -!> \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 includes f: 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 the Coriolis term - ! is added separately to the momentum tendencies. - fCoef = 0 - end if - - end subroutine ocn_diagnostics_init!}}} - -!*********************************************************************** -! -! routine computeKPPInputFields -! -!> \brief -!> Compute fields necessary to drive the CVMix KPP module -!> \author Todd Ringler -!> \date 20 August 2013 -!> \details -!> CVMix/KPP requires the following fields as intent(in): -!> buoyancyForcingOBL -!> surfaceFrictionVelocity -!> bulkRichardsonNumber -!> -! -!----------------------------------------------------------------------- - - subroutine computeKPPInputFields(state, forcing, mesh, diagnostics, scratch)!{{{ - - type (state_type), intent(inout) :: state !< Input/Output: State information - type (forcing_type), intent(in) :: forcing !< Input: Forcing information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - type (diagnostics_type), intent(inout) :: diagnostics !< Diagnostics information derived from State - type (scratch_type), intent(inout) :: scratch !< Input: scratch variables - - ! scalars - integer :: nCells, nVertLevels - - ! integer pointers - integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell - integer, dimension(:,:), pointer :: edgesOnCell - - ! real pointers - real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell - real (kind=RKIND), dimension(:), pointer :: penetrativeTemperatureFlux, surfaceMassFlux, surfaceWindStressMagnitude, & - buoyancyForcingOBL, surfaceFrictionVelocity, boundaryLayerDepth, penetrativeTemperatureFluxOBL - real (kind=RKIND), dimension(:,:), pointer :: & - layerThickness, zMid, zTop, bulkRichardsonNumber, tracersSurfaceValues, densitySurfaceDisplaced, density, & - normalVelocity, surfaceTracerFlux, thermalExpansionCoeff, salineContractionCoeff - - ! local - integer :: iCell, iEdge, i, k, err, indexTempFlux, indexSaltFlux - real (kind=RKIND) :: numerator, denominator, factor, deltaVelocitySquared, turbulentVelocitySquared, delU2, invAreaCell - - ! set the parameter turbulentVelocitySquared - turbulentVelocitySquared = 0.001 - - ! set scalar values - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels - indexTempFlux = forcing % index_surfaceTemperatureFlux - indexSaltFlux = forcing % index_surfaceSalinityFlux - - ! set pointers into state, mesh, diagnostics and scratch - normalVelocity => state % normalVelocity % array - layerThickness => state % layerThickness % array - - maxLevelCell => mesh % maxLevelCell % array - nEdgesOnCell => mesh % nEdgesOnCell % array - edgesOnCell => mesh % edgesOnCell % array - areaCell => mesh % areaCell % array - dcEdge => mesh % dcEdge % array - dvEdge => mesh % dvEdge % array - - zMid => diagnostics % zMid % array - zTop => diagnostics % zTop % array - density => diagnostics % density % array - bulkRichardsonNumber => diagnostics % bulkRichardsonNumber % array - tracersSurfaceValues => diagnostics % tracersSurfaceValue % array - boundaryLayerDepth => diagnostics % boundaryLayerDepth % array - surfaceFrictionVelocity => diagnostics % surfaceFrictionVelocity % array - penetrativeTemperatureFluxOBL => diagnostics % penetrativeTemperatureFluxOBL % array - buoyancyForcingOBL => diagnostics % buoyancyForcingOBL % array - - normalVelocity => state % normalVelocity % array - - surfaceMassFlux => forcing % surfaceMassFlux % array - surfaceTracerFlux => forcing % surfaceTracerFlux % array - penetrativeTemperatureFlux => forcing % penetrativeTemperatureFlux % array - surfaceWindStressMagnitude => forcing % surfaceWindStressMagnitude % array - - ! allocate scratch space displaced density computation - call mpas_allocate_scratch_field(scratch % densitySurfaceDisplaced, .true.) - call mpas_allocate_scratch_field(scratch % thermalExpansionCoeff, .true.) - call mpas_allocate_scratch_field(scratch % salineContractionCoeff, .true.) - densitySurfaceDisplaced => scratch % densitySurfaceDisplaced % array - thermalExpansionCoeff => scratch % thermalExpansionCoeff % array - salineContractionCoeff => scratch % salineContractionCoeff % array - - ! compute EOS by displacing SST/SSS to every vertical layer in column - call ocn_equation_of_state_density(state, diagnostics, mesh, 0, 'surfaceDisplaced', densitySurfaceDisplaced, err, & - thermalExpansionCoeff, salineContractionCoeff) - - ! set value to out-of-bounds - bulkRichardsonNumber(:,:) = -1.0e34 - - do iCell=1,nCells - invAreaCell = 1.0 / areaCell(iCell) - - ! compute surface buoyancy forcing based on surface fluxes of mass, temperature, salinity and frazil (frazil to be added later) - ! since this computation is confusing, variables, units and sign convention is repeated here - ! everything below should be consistent with that specified in Registry - ! everything below should be consistent with the CVMix/KPP documentation: https://www.dropbox.com/s/6hqgc0rsoa828nf/cvmix_20aug2013.pdf - ! - ! surfaceMassFlux: surface mass flux, m/s, positive into ocean - ! surfaceTracerFlux(indexTempFlux): non-penetrative temperature flux, C m/s, positive into ocean - ! penetrativeTemperatureFlux: penetrative surface temperature flux at ocean surface, positive into ocean - ! surfaceTracerFlux(indexSaltFlux): salinity flux, PSU m/s, positive into ocean - ! penetrativeTemperatureFluxOBL: penetrative temperature flux computed at z=OBL, positive down - ! - ! note: the following fields used the CVMix/KPP computation of buoyancy forcing are not included here - ! 1. Tm: temperature associated with surfaceMassFlux, C (here we assume Tm == temperatureSurfaceValue) - ! 2. Sm: salinity associated with surfaceMassFlux, PSU (here we assume Sm == salinitySurfaceValue and account for salinity flux in surfaceTracerFlux array) - ! - buoyancyForcingOBL(iCell) = thermalExpansionCoeff (1,iCell) * & - (surfaceTracerFlux(indexTempFlux,iCell) + penetrativeTemperatureFlux(iCell) - penetrativeTemperatureFluxOBL(iCell)) & - - salineContractionCoeff(1,iCell) * surfaceTracerFlux(indexSaltFlux,iCell) - - ! at this point, buoyancyForcingOBL has units of m/s - ! change into units of m/s^3 (which can be thought of as units of buoyancy per second) - buoyancyForcingOBL(iCell) = buoyancyForcingOBL(iCell) * gravity / max(boundaryLayerDepth(iCell),layerThickness(1,iCell)) - - ! compute surface friction velocity - surfaceFrictionVelocity(iCell) = surfacewindStressMagnitude(iCell) / config_density0 - - ! loop over vertical to compute bulk Richardson number - do k=1,maxLevelCell(iCell) - - ! find deltaVelocitySquared defined at cell centers - deltaVelocitySquared = 0.0 - do i = 1, nEdgesOnCell(iCell) - iEdge = edgesOnCell(i, iCell) - factor = 0.5 * dcEdge(iEdge) * dvEdge(iEdge) * invAreaCell - delU2 = (normalVelocity(1,iEdge) - normalVelocity(k,iEdge))**2 - deltaVelocitySquared = deltaVelocitySquared + factor * delU2 - enddo - - numerator = gravity * (zTop(1,iCell) - zMid(k,iCell)) * (density(k,iCell) - densitySurfaceDisplaced(k,iCell)) - denominator = config_density0 * (deltaVelocitySquared + turbulentVelocitySquared) - - ! compute bulk Richardson number - bulkRichardsonNumber(k,iCell) = numerator / denominator - - enddo - enddo - - ! deallocate scratch space - call mpas_deallocate_scratch_field(scratch % densitySurfaceDisplaced, .true.) - call mpas_deallocate_scratch_field(scratch % thermalExpansionCoeff, .true.) - call mpas_deallocate_scratch_field(scratch % salineContractionCoeff, .true.) - - end subroutine computeKPPInputFields!}}} - - -end module ocn_diagnostics - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_gm.F b/src/core_ocean/mpas_ocn_gm.F deleted file mode 100644 index ae4d1d6208..0000000000 --- a/src/core_ocean/mpas_ocn_gm.F +++ /dev/null @@ -1,147 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -module ocn_gm - - use mpas_grid_types - use mpas_configure - use mpas_timer - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_gm_compute_uBolus - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - -contains - - subroutine ocn_gm_compute_uBolus(state, diagnostics, mesh)!{{{ - implicit none - type(state_type), intent(inout) :: state !< Input/Output: State information - type(diagnostics_type), intent(inout) :: diagnostics !< Input/Output: Diagnostics information - type(mesh_type), intent(in) :: mesh !< Input: Mesh information - - real(kind=RKIND), dimension(:,:), pointer :: uBolusGM, hEddyFlux, layerThicknessEdge - - integer, dimension(:), pointer :: maxLevelEdgeTop - integer :: k, iEdge, nEdges - - uBolusGM => diagnostics % uBolusGM % array - hEddyFlux => diagnostics % hEddyFlux % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - - nEdges = mesh % nEdges - - call ocn_gm_compute_hEddyFlux(state, diagnostics, mesh) - - if (config_vert_coord_movement .EQ. 'impermeable_interfaces') then - - do iEdge = 1, nEdges - do k = 1, maxLevelEdgeTop(iEdge) - uBolusGM(k,iEdge) = hEddyFlux(k,iEdge)/layerThicknessEdge(k,iEdge) - end do - end do - - else - - ! Nothing for now for all other mesh types (zlevel, zstar, ztilde) - uBolusGM(:,:) = 0.0 - - end if - - end subroutine ocn_gm_compute_uBolus!}}} - - subroutine ocn_gm_compute_hEddyFlux(state, diagnostics, mesh)!{{{ - implicit none - type(state_type), intent(inout) :: state !< Input/Output: State information - type(diagnostics_type), intent(in) :: diagnostics !< Input: Diagnostics information - type(mesh_type), intent(in) :: mesh !< Input: Mesh information - - real(kind=RKIND), dimension(:,:), pointer :: hEddyFlux, layerThickness - real(kind=RKIND), dimension(:), pointer :: dcEdge - integer, dimension(:,:), pointer :: cellsOnEdge - integer, dimension(:), pointer :: maxLevelEdgeTop - integer :: k, cell1, cell2, iEdge, nEdges - - hEddyFlux => diagnostics % hEddyFlux % array - layerThickness => state % layerThickness % array - - dcEdge => mesh % dcEdge % array - cellsOnEdge => mesh % cellsOnEdge % array - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - - nEdges = mesh % nEdges - - hEddyFlux(:,:) = 0.0 - - if (config_vert_coord_movement .EQ. 'impermeable_interfaces') then - do iEdge = 1,nEdges - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - do k=1,maxLevelEdgeTop(iEdge) - hEddyFlux(k,iEdge) = -config_h_kappa * (layerThickness(k,cell2) - layerThickness(k,cell1)) / dcEdge(iEdge) - end do - end do - else - - !Nothing for now for all other mesh types (zlevel, zstar, ztilde) - - end if - - end subroutine ocn_gm_compute_hEddyFlux!}}} - - subroutine ocn_get_h_kappa(diagnostics, mesh)!{{{ - - type (diagnostics_type), intent(inout) :: diagnostics !< Input/Output: Diagnostics information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - - real(kind=RKIND), dimension(:,:), pointer :: hKappa - - - hKappa => diagnostics % hKappa % array - - hKappa(:,:) = config_h_kappa - - - end subroutine ocn_get_h_kappa!}}} - - subroutine ocn_get_h_kappa_q(diagnostics, mesh)!{{{ - - type (diagnostics_type), intent(inout) :: diagnostics !< Input/Output: Diagnostics information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - - real(kind=RKIND), dimension(:,:), pointer :: hKappaQ - - - hKappaQ => diagnostics % hKappaQ % array - - hKappaQ(:,:) = config_h_kappa_q - - - end subroutine ocn_get_h_kappa_q!}}} - -end module ocn_gm diff --git a/src/core_ocean/mpas_ocn_mpas_core.F b/src/core_ocean/mpas_ocn_mpas_core.F deleted file mode 100644 index adc49d8eb9..0000000000 --- a/src/core_ocean/mpas_ocn_mpas_core.F +++ /dev/null @@ -1,1273 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! mpas_core -! -!> \brief Main driver for MPAS ocean core -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This module contains initialization and timestep drivers for -!> the MPAS ocean core. -! -!----------------------------------------------------------------------- - -module mpas_core - - use mpas_configure - use mpas_framework - use mpas_timekeeping - use mpas_dmpar - use mpas_timer - use mpas_io_units - - use ocn_global_diagnostics - use ocn_time_integration - use ocn_tendency - use ocn_diagnostics - use ocn_test - - use ocn_thick_hadv - use ocn_thick_vadv - use ocn_thick_ale - use ocn_thick_surface_flux - - use ocn_vel_pressure_grad - use ocn_vel_vadv - use ocn_vel_hmix - use ocn_vel_forcing - use ocn_vel_coriolis - - use ocn_tracer_hmix - use ocn_tracer_surface_flux - use ocn_tracer_short_wave_absorption - use ocn_gm - - use ocn_equation_of_state - - use ocn_vmix - - use ocn_time_average - - use ocn_forcing - use ocn_sea_ice - - use ocn_constants - - type (io_output_object), save :: restart_obj - - integer :: current_outfile_frames - - type (MPAS_Clock_type) :: clock - - integer, parameter :: outputAlarmID = 1 - integer, parameter :: restartAlarmID = 2 - integer, parameter :: statsAlarmID = 3 - integer, parameter :: coupleAlarmID = 4 - - type (timer_node), pointer :: globalDiagTimer, timeIntTimer, testSuiteTimer - type (timer_node), pointer :: initDiagSolveTimer - - contains - -!*********************************************************************** -! -! routine mpas_core_init -! -!> \brief Initialize MPAS-Ocean core -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine calls all initializations required to begin a -!> simulation with MPAS-Ocean -! -!----------------------------------------------------------------------- - - subroutine mpas_core_init(domain, startTimeStamp)!{{{ - - use mpas_grid_types - use ocn_tracer_advection - - implicit none - - type (domain_type), intent(inout) :: domain - character(len=*), intent(out) :: startTimeStamp - - real (kind=RKIND) :: dt - type (block_type), pointer :: block - type (dm_info) :: dminfo - - integer :: err, err_tmp - real (kind=RKIND) :: maxDensity, maxDensity_global - - dminfo = domain % dminfo - - ! 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_thick_surface_flux_init(err_tmp) - err = ior(err, err_tmp) - call ocn_thick_ale_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) - err = ior(err, err_tmp) - call ocn_vel_forcing_init(err_tmp) - err = ior(err, err_tmp) - - call ocn_tracer_hmix_init(err_tmp) - err = ior(err, err_tmp) - call ocn_tracer_surface_flux_init(err_tmp) - err = ior(err, err_tmp) - call ocn_tracer_advection_init(err_tmp) - err = ior(err,err_tmp) - call ocn_tracer_short_wave_absorption_init(err_tmp) - err = ior(err,err_tmp) - - call ocn_vmix_init(domain,err_tmp) - err = ior(err, err_tmp) - - call ocn_equation_of_state_init(err_tmp) - err = ior(err, err_tmp) - - call ocn_tendency_init(err_tmp) - err = ior(err,err_tmp) - call ocn_diagnostics_init(err_tmp) - err = ior(err,err_tmp) - - call ocn_forcing_init(err_tmp) - err = ior(err,err_tmp) - - - call ocn_global_diagnostics_init(dminfo,err_tmp) - err = ior(err, err_tmp) - - call ocn_sea_ice_init(domain % blocklist % mesh % nVertLevels, err_tmp) - err = ior(err, err_tmp) - - call ocn_constants_init() - - call mpas_timer_init(domain) - - if(err.eq.1) then - call mpas_dmpar_abort(dminfo) - endif - - call ocn_init_vert_coord(domain) - - call ocn_compute_max_level(domain) - - if (.not.config_do_restart) call ocn_init_split_timestep(domain) - - write (stdoutUnit,'(a,a)') ' Vertical coordinate movement is: ',trim(config_vert_coord_movement) - - if (config_vert_coord_movement.ne.'fixed'.and. & - config_vert_coord_movement.ne.'uniform_stretching'.and. & - config_vert_coord_movement.ne.'impermeable_interfaces'.and. & - config_vert_coord_movement.ne.'user_specified') then - write (stderrUnit,*) ' Incorrect choice of config_vert_coord_movement.' - call mpas_dmpar_abort(dminfo) - endif - - write (stdoutUnit,'(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 (stderrUnit,*) ' Incorrect choice of config_pressure_gradient_type.' - call mpas_dmpar_abort(dminfo) - endif - - if(config_vert_coord_movement .ne. 'impermeable_interfaces' .and. config_pressure_gradient_type .eq. 'MontgomeryPotential') then - write (stderrUnit,*) ' 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_coord_movement.ne.'fixed')then - write (stderrUnit,*) 'filter_btr_mode has only been tested with'// & - ' config_vert_coord_movement=fixed.' - call mpas_dmpar_abort(dminfo) - endif - - ! find the maximum value of the meshDensity - if (config_maxMeshDensity < 0.0) then - maxDensity=-1 - block => domain % blocklist - do while (associated(block)) - maxDensity = max(maxDensity, maxval(block % mesh % meshDensity % array)) - block => block % next - end do - call mpas_dmpar_max_real(domain % dminfo, maxDensity, maxDensity_global) - config_maxMeshDensity = maxDensity_global - endif - - ! - ! Initialize core - ! - dt = config_dt - - call ocn_simulation_clock_init(domain, dt, startTimeStamp) - - block => domain % blocklist - do while (associated(block)) - call mpas_init_block(block, block % mesh, dt, err) - if(err.eq.1) then - call mpas_dmpar_abort(dminfo) - endif - block % diagnostics % xtime % scalar = startTimeStamp - block => block % next - end do - - if (config_conduct_tests) then - call mpas_timer_start("test suite", .false., testSuiteTimer) - call ocn_test_suite(domain,err) - call mpas_timer_stop("test suite", testSuiteTimer) - endif - - 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) - endif - - current_outfile_frames = 0 - - end subroutine mpas_core_init!}}} - -!*********************************************************************** -! -! routine mpas_simulation_clock_init -! -!> \brief Initialize timer variables -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine initializes all timer variables -! -!----------------------------------------------------------------------- - - subroutine ocn_simulation_clock_init(domain, dt, startTimeStamp)!{{{ - - implicit none - - type (domain_type), intent(inout) :: domain - real (kind=RKIND), intent(in) :: dt - character(len=*), intent(out) :: startTimeStamp - - type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime - type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep - character(len=StrKIND) :: restartTimeStamp - integer :: ierr - - if(config_start_time == 'file') then - open(22,file=config_restart_timestamp_name,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) - - if (trim(config_stop_time) /= "none") then - call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr) - if(startTime + runduration /= stopTime) then - write(stderrUnit,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.' - end if - end if - else if (trim(config_stop_time) /= "none") then - call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr) - call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr) - else - write(stderrUnit,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' - call mpas_dmpar_finalize(domain % dminfo) - end if - - ! set output alarm - call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) - - ! set restart alarm, if necessary - if (trim(config_restart_interval) /= "none") then - call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) - end if - - !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 - - call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr) - - end subroutine ocn_simulation_clock_init!}}} - -!*********************************************************************** -! -! routine mpas_init_block -! -!> \brief Initialize blocks within MPAS-Ocean core -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine calls all block-level initializations required to begin a -!> simulation with MPAS-Ocean -! -!----------------------------------------------------------------------- - - subroutine mpas_init_block(block, mesh, dt, err)!{{{ - - use mpas_grid_types - use mpas_rbf_interpolation - use mpas_vector_operations - use mpas_vector_reconstruction - use mpas_tracer_advection_helpers - - implicit none - - type (block_type), intent(inout) :: block - type (mesh_type), intent(inout) :: mesh - real (kind=RKIND), intent(in) :: dt - integer, intent(out) :: err - integer :: i, iEdge, iCell, k - integer :: err1 - - call ocn_setup_sign_and_index_fields(mesh) - call mpas_initialize_deriv_two(mesh, mesh % derivTwo % array, err) - call mpas_tracer_advection_coefficients(mesh, & - config_horiz_tracer_adv_order, mesh % derivTwo % array, mesh % advCoefs % array, & - mesh % advCoefs3rd % array, mesh % nAdvCellsForEdge % array, mesh % advCellsForEdge % array, & - err1, mesh % maxLevelCell % array, mesh % highOrderAdvectionMask % array, & - mesh % boundaryCell % array) - err = ior(err, err1) - - call ocn_time_average_init(block % average) - - call mpas_timer_start("diagnostic solve", .false., initDiagSolveTimer) - call ocn_diagnostic_solve(dt, block % state % time_levs(1) % state, block % forcing, mesh, block % diagnostics, block % scratch) - call mpas_timer_stop("diagnostic solve", initDiagSolveTimer) - - ! Compute velocity transport, used in advection terms of layerThickness and tracer tendency - block % diagnostics % uTransport % array(:,:) & - = block % state % time_levs(1) % state % normalVelocity % array(:,:) & - + block % diagnostics % uBolusGM % array(:,:) - - call ocn_compute_mesh_scaling(mesh) - - call mpas_rbf_interp_initialize(mesh) - call mpas_initialize_tangent_vectors(mesh, mesh % edgeTangentVectors % array) - - call mpas_init_reconstruct(mesh) - call mpas_reconstruct(mesh, block % state % time_levs(1) % state % normalVelocity % array, & - block % diagnostics % normalVelocityX % array, & - block % diagnostics % normalVelocityY % array, & - block % diagnostics % normalVelocityZ % array, & - block % diagnostics % normalVelocityZonal % array, & - block % diagnostics % normalVelocityMeridional % array & - ) - - ! initialize velocities and tracers on land to be zero. - - block % mesh % areaCell % array(block % mesh % nCells+1) = -1.0e34 - - block % state % time_levs(1) % state % layerThickness % array(:,block % mesh % nCells+1) = 0.0 - - do iEdge=1,block % mesh % nEdges - block % state % time_levs(1) % state % normalVelocity % array( & - block % mesh % maxLevelEdgeTop % array(iEdge)+1 & - :block % mesh % maxLevelEdgeBot % array(iEdge), iEdge) = 0.0 - - block % state % time_levs(1) % state % normalVelocity % array( & - block % mesh % maxLevelEdgeBot % array(iEdge)+1: & - block % mesh % nVertLevels,iEdge) = -1.0e34 - end do - do iCell=1,block % mesh % nCells - block % state % time_levs(1) % state % tracers % array( & - :, block % mesh % maxLevelCell % array(iCell)+1 & - :block % mesh % nVertLevels,iCell) = -1.0e34 - end do - - do i=2,nTimeLevs - call mpas_copy_state(block % state % time_levs(i) % state, & - block % state % time_levs(1) % state) - end do - - end subroutine mpas_init_block!}}} - -!*********************************************************************** -! -! routine mpas_core_run -! -!> \brief Main driver for MPAS-Ocean time-stepping -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine includes the time-stepping loop, and calls timer -!> routines to write output and restart files. -! -!----------------------------------------------------------------------- - - subroutine mpas_core_run(domain, output_obj, output_frame)!{{{ - - use mpas_kind_types - use mpas_grid_types - use mpas_io_output - use mpas_timer - - implicit none - - type (domain_type), intent(inout) :: domain - type (io_output_object), intent(inout) :: output_obj - integer, intent(inout) :: output_frame - - integer :: itimestep - real (kind=RKIND) :: dt - type (block_type), pointer :: block_ptr - - type (MPAS_Time_Type) :: currTime - character(len=StrKIND) :: timeStamp - integer :: ierr - - ! Eventually, dt should be domain specific - dt = config_dt - - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) - write(stderrUnit,*) 'Initial time ', trim(timeStamp) - - 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)) - call ocn_time_average_init(block_ptr % average) - block_ptr => block_ptr % next - end do - - ! During integration, time level 1 stores the model state at the beginning of the - ! time step, and time level 2 stores the state advanced dt in time by timestep(...) - itimestep = 0 - do while (.not. mpas_is_clock_stop_time(clock)) - - itimestep = itimestep + 1 - call mpas_advance_clock(clock) - - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) - write(stderrUnit,*) 'Doing timestep ', trim(timeStamp) - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call ocn_forcing_build_arrays(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % forcing, ierr) - call ocn_forcing_build_transmission_array(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % forcing, ierr) - block_ptr => block_ptr % next - end do - - call mpas_timer_start("time integration", .false., timeIntTimer) - call mpas_timestep(domain, itimestep, dt, timeStamp) - call mpas_timer_stop("time integration", timeIntTimer) - - ! Move time level 2 fields back into time level 1 for next time step - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_shift_time_levels_state(block_ptr % state) - block_ptr => block_ptr % next - end do - - 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. - 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)) - end if - - block_ptr => domain % blocklist - do while (associated(block_ptr)) - call ocn_time_average_normalize(block_ptr % average) - block_ptr => block_ptr % next - end do - - call ocn_write_output_frame(output_obj, output_frame, domain) - - block_ptr => domain % blocklist - do while (associated(block_ptr)) - call ocn_time_average_init(block_ptr % average) - block_ptr => block_ptr % next - end do - end if - - if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then - call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr) - - ! Write one restart time per file - call mpas_output_state_init(restart_obj, domain, "RESTART", trim(timeStamp)) - call mpas_output_state_for_domain(restart_obj, domain, 1) - call mpas_output_state_finalize(restart_obj, domain % dminfo) - end if - - end do - - end subroutine mpas_core_run!}}} - - subroutine ocn_write_output_frame(output_obj, output_frame, domain)!{{{ - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Compute diagnostic fields for a domain and write model state to output file - ! - ! Input/Output: domain - contains model state; diagnostic field are computed - ! before returning - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_grid_types - use mpas_io_output - use mpas_vector_reconstruction - - implicit none - - integer, intent(inout) :: output_frame - type (domain_type), intent(inout) :: domain - type (io_output_object), intent(inout) :: output_obj - - integer :: i, j, k - integer :: eoe - type (block_type), pointer :: block_ptr - - ! Compute output diagnostics - block_ptr => domain % blocklist - do while (associated(block_ptr)) - call ocn_compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh) - - call mpas_allocate_scratch_field(block_ptr % scratch % windStressFull, .true.) - call mpas_allocate_scratch_field(block_ptr % scratch % windStressX, .true.) - call mpas_allocate_scratch_field(block_ptr % scratch % windStressY, .true.) - call mpas_allocate_scratch_field(block_ptr % scratch % windStressZ, .true.) - call mpas_allocate_scratch_field(block_ptr % scratch % windStressZonal, .true.) - call mpas_allocate_scratch_field(block_ptr % scratch % windStressMeridional, .true.) - - block_ptr % scratch % windStressFull % array = 0.0_RKIND - block_ptr % scratch % windStressFull % array(1,:) = block_ptr % forcing % surfaceWindStress % array - - call mpas_reconstruct(block_ptr % mesh, block_ptr % scratch % windStressFull % array, & - block_ptr % scratch % windStressX % array, & - block_ptr % scratch % windStressY % array, & - block_ptr % scratch % windStressZ % array, & - block_ptr % scratch % windStressZonal % array, & - block_ptr % scratch % windStressMeridional % array) - - block_ptr % diagnostics % windStressZonalDiag % array(:) = block_ptr % scratch % windStressZonal % array(1,:) - block_ptr % diagnostics % windStressMeridionalDiag % array(:) = block_ptr % scratch % windStressMeridional % array(1,:) - - call mpas_deallocate_scratch_field(block_ptr % scratch % windStressFull, .true.) - call mpas_deallocate_scratch_field(block_ptr % scratch % windStressX, .true.) - call mpas_deallocate_scratch_field(block_ptr % scratch % windStressY, .true.) - call mpas_deallocate_scratch_field(block_ptr % scratch % windStressZ, .true.) - call mpas_deallocate_scratch_field(block_ptr % scratch % windStressZonal, .true.) - call mpas_deallocate_scratch_field(block_ptr % scratch % windStressMeridional, .true.) - - block_ptr => block_ptr % next - end do - - call mpas_output_state_for_domain(output_obj, domain, output_frame) - output_frame = output_frame + 1 - - ! reset frame if the maximum number of frames per outfile has been reached - if (config_frames_per_outfile > 0) then - current_outfile_frames = current_outfile_frames + 1 - if(current_outfile_frames >= config_frames_per_outfile) then - current_outfile_frames = 0 - output_frame = 1 - end if - end if - - end subroutine ocn_write_output_frame!}}} - - subroutine ocn_compute_output_diagnostics(state, mesh)!{{{ - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Compute diagnostic fields for a domain - ! - ! Input: state - contains model prognostic fields - ! mesh - contains mesh metadata - ! - ! Output: state - upon returning, diagnostic fields will have be computed - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_grid_types - - implicit none - - type (state_type), intent(inout) :: state - type (mesh_type), intent(in) :: mesh - - integer :: i, eoe - integer :: iEdge, k - - end subroutine ocn_compute_output_diagnostics!}}} - -!*********************************************************************** -! -! routine mpas_core_run -! -!> \brief Sub-driver for MPAS-Ocean time-stepping -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine calls the time integration routine within a time-stepping loop. -! -!----------------------------------------------------------------------- - - subroutine mpas_timestep(domain, itimestep, dt, timeStamp)!{{{ - - use mpas_kind_types - use mpas_grid_types - - implicit none - - type (domain_type), intent(inout) :: domain - integer, intent(in) :: itimestep - real (kind=RKIND), intent(in) :: dt - character(len=*), intent(in) :: timeStamp - - type (block_type), pointer :: block_ptr - integer :: ierr - - 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 - - !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) - -! block_ptr => domain % blocklist -! if (associated(block_ptr % next)) then -! write(stderrUnit,*) '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, 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_vert_coord(domain)!{{{ - ! Initialize zlevel-type variables and adjust initial conditions for - ! partial bottom cells. - - use mpas_grid_types - use mpas_configure - - implicit none - - type (domain_type), intent(inout) :: domain - type (dm_info) :: dminfo - - integer :: i, iCell, iEdge, iVertex, k, km1, nCells, num_tracers - type (block_type), pointer :: block - - integer :: iTracer, cell, cell1, cell2 - real (kind=RKIND) :: normalThicknessFluxSum, thicknessSum, hEdge1, zMidPBC - - integer, dimension(:), pointer :: maxLevelCell - real (kind=RKIND), dimension(:), pointer :: refBottomDepth, & - refBottomDepthTopOfCell, vertCoordMovementWeights, bottomDepth, refZMid, refLayerThickness - real (kind=RKIND), dimension(:), allocatable :: minBottomDepth, minBottomDepthMid, zMidZLevel - - real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:,:,:), pointer :: tracers - integer :: nVertLevels - logical :: consistentSSH - - ! Initialize z-level mesh variables from h, read in from input file. - block => domain % blocklist - do while (associated(block)) - - layerThickness => block % state % time_levs(1) % state % layerThickness % 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 - maxLevelCell => block % mesh % maxLevelCell % array - - restingThickness => block % verticalMesh % restingThickness % array - refZMid => block % verticalMesh % refZMid % array - refLayerThickness => block % verticalMesh % refLayerThickness % array - - nCells = block % mesh % nCells - nVertLevels = block % mesh % nVertLevels - num_tracers = size(tracers, dim=1) - - ! TopOfCell needed where zero depth for the very top may be referenced. - refBottomDepthTopOfCell(1) = 0.0 - do k = 1,nVertLevels - refBottomDepthTopOfCell(k+1) = refBottomDepth(k) - refLayerThickness(k) = refBottomDepth(k) - refBottomDepthTopOfCell(k) - refZMid(k) = - refBottomDepthTopOfCell(1) - refLayerThickness(k)/2.0 - end do - - ! Initialization of vertCoordMovementWeights. This determines how SSH perturbations - ! are distributed throughout the column. - if (config_vert_coord_movement.eq.'fixed') then - - vertCoordMovementWeights = 0.0 - vertCoordMovementWeights(1) = 1.0 - - elseif (config_vert_coord_movement.eq.'uniform_stretching') then - - 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.and.config_alter_ICs_for_pbcs) then - - if (config_pbc_alteration_type.eq.'partial_cell') then - - write (stdoutUnit,'(a)') ' Altering bottomDepth to avoid very thin cells.' - write (stdoutUnit,'(a)') ' Altering layerThickness 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. - - minBottomDepth(1) = (1.0-config_min_pbc_fraction)*refBottomDepth(1) - minBottomDepthMid(1) = 0.5*(minBottomDepth(1) + refBottomDepthTopOfCell(1)) - zMidZLevel(1) = - 0.5*(refBottomDepth(1) + refBottomDepthTopOfCell(1)) - do k=2,nVertLevels - minBottomDepth(k) = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) - minBottomDepthMid(k) = 0.5*(minBottomDepth(k) + refBottomDepthTopOfCell(k)) - zMidZLevel(k) = - 0.5*(refBottomDepth(k) + refBottomDepthTopOfCell(k)) - enddo - - do iCell=1,nCells - - ! Change value of maxLevelCell for partial bottom cells - k = maxLevelCell(iCell) - 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 - ! reset k to new value of maxLevelCell - k = maxLevelCell(iCell) - - ! Alter thickness of bottom level to account for PBC - layerThickness(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)) - km1 = max(k-1,1) - do iTracer=1,num_tracers - tracers(iTracer,k,iCell) = tracers(iTracer,k,iCell) & - + (tracers(iTracer,km1,iCell) - tracers(iTracer,k,iCell)) & - /(zMidZLevel(km1)-zMidZLevel(k)+1.0e-16) & - *(zMidPBC - zMidZLevel(k)) - enddo - - enddo - - deallocate(minBottomDepth,zMidZLevel) - - elseif (config_pbc_alteration_type.eq.'full_cell') then - - do iCell = 1,nCells - bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) - enddo - - else - - write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' - call mpas_dmpar_abort(dminfo) - - endif - - endif ! .not.config_do_restart - - if (.not.config_do_restart) then - - ! Layer thickness when the ocean is at rest, i.e. without SSH or internal perturbations. - ! This is applied only from the initial condition - if (config_set_restingThickness_to_IC) then - restingThickness = layerThickness - endif - - endif ! .not.config_do_restart.and.config_alter_ICs_for_pbcs - - if (config_check_ssh_consistency) then - consistentSSH = .true. - do iCell = 1,nCells - ! Check if abs(ssh)>2m. If so, print warning. - if (abs(sum(layerThickness(1:maxLevelCell(iCell),iCell))-bottomDepth(iCell))>2.0) then - consistentSSH = .false. - write (stderrUnit,'(a)') ' Warning: abs(sum(h)-bottomDepth)>2m. Most likely, initial layerThickness does not match bottomDepth.' - write (stderrUnit,*) ' iCell, K=maxLevelCell(iCell), bottomDepth(iCell),sum(h),bottomDepth: ', & - iCell, maxLevelCell(iCell), bottomDepth(iCell),sum(layerThickness(1:maxLevelCell(iCell),iCell)),bottomDepth(iCell), & - layerThickness(maxLevelCell(iCell),iCell) - endif - enddo - - if (.not. consistentSSH) then - write(stderrUnit,*) 'Warning: SSH is not consistent. Most likely, initial layerThickness does not match bottomDepth.' - end if - - endif ! config_check_ssh_consistency - - if (config_check_zlevel_consistency) then - do iCell = 1,nCells - ! Check that bottomDepth and maxLevelCell match. Some older meshs do not have the bottomDepth variable. - if (bottomDepth(iCell) > refBottomDepth(maxLevelCell(iCell)).or. & - bottomDepth(iCell) < refBottomDepthTopOfCell(maxLevelCell(iCell))) then - write (stderrUnit,'(a)') ' fatal error: bottomDepth and maxLevelCell do not match:' - write (stderrUnit,'(a,2i5,10f10.2)') ' iCell, maxLevelCell(iCell), bottomDepth(iCell): ', & - iCell, maxLevelCell(iCell), bottomDepth(iCell) - write (stderrUnit,'(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_vert_coord!}}} - - subroutine ocn_init_split_timestep(domain)!{{{ - ! Initialize splitting variables - - use mpas_grid_types - use mpas_configure - - implicit none - - type (domain_type), intent(inout) :: domain - - integer :: i, iCell, iEdge, iVertex, k - type (block_type), pointer :: block - - integer :: iTracer, cell, cell1, cell2 - real (kind=RKIND) :: normalThicknessFluxSum, layerThicknessSum, layerThicknessEdge1 - real (kind=RKIND), dimension(:), pointer :: refBottomDepth - - real (kind=RKIND), dimension(:,:), pointer :: layerThickness - integer :: nVertLevels - - ! Initialize z-level mesh variables from h, read in from input file. - block => domain % blocklist - do while (associated(block)) - - layerThickness => block % state % time_levs(1) % state % layerThickness % 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_integrator) == 'unsplit_explicit') then - block % state % time_levs(1) % state % normalBarotropicVelocity % array(:) = 0.0 - - block % state % time_levs(1) % state % normalBaroclinicVelocity % array(:,:) & - = block % state % time_levs(1) % state % normalVelocity % array(:,:) - - 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 % layerThickness % array(1,iCell) & - = block % mesh % refBottomDepth % array(1) - enddo - endif - - do iEdge=1,block % mesh % nEdges - cell1 = block % mesh % cellsOnEdge % array(1,iEdge) - cell2 = block % mesh % cellsOnEdge % array(2,iEdge) - - ! normalBarotropicVelocity = sum(u)/sum(h) on each column - ! ocn_diagnostic_solve has not yet been called, so compute hEdge - ! just for this edge. - - ! thicknessSum is initialized outside the loop because on land boundaries - ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a - ! nonzero value to avoid a NaN. - layerThicknessEdge1 = 0.5*( & - block % state % time_levs(1) % state % layerThickness % array(1,cell1) & - + block % state % time_levs(1) % state % layerThickness % array(1,cell2) ) - normalThicknessFluxSum = layerThicknessEdge1*block % state % time_levs(1) % state % normalVelocity % array(1,iEdge) - layerThicknessSum = layerThicknessEdge1 - - do k=2,block % mesh % maxLevelEdgeTop % array(iEdge) - ! ocn_diagnostic_solve has not yet been called, so compute hEdge - ! just for this edge. - layerThicknessEdge1 = 0.5*( & - block % state % time_levs(1) % state % layerThickness % array(k,cell1) & - + block % state % time_levs(1) % state % layerThickness % array(k,cell2) ) - - normalThicknessFluxSum = normalThicknessFluxSum & - + layerThicknessEdge1*block % state % time_levs(1) % state % normalVelocity % array(k,iEdge) - layerThicknessSum = layerThicknessSum + layerThicknessEdge1 - - enddo - block % state % time_levs(1) % state % normalBarotropicVelocity % array(iEdge) = normalThicknessFluxSum/layerThicknessSum - - ! normalBaroclinicVelocity(k,iEdge) = normalVelocity(k,iEdge) - normalBarotropicVelocity(iEdge) - do k=1,block % mesh % maxLevelEdgeTop % array(iEdge) - block % state % time_levs(1) % state % normalBaroclinicVelocity % array(k,iEdge) & - = block % state % time_levs(1) % state % normalVelocity % array(k,iEdge) & - - block % state % time_levs(1) % state % normalBarotropicVelocity % array(iEdge) - enddo - - ! normalBaroclinicVelocity=0, normalVelocity=0 on land cells - do k=block % mesh % maxLevelEdgeTop % array(iEdge)+1, block % mesh % nVertLevels - block % state % time_levs(1) % state % normalBaroclinicVelocity % array(k,iEdge) = 0.0 - block % state % time_levs(1) % state % normalVelocity % array(k,iEdge) = 0.0 - enddo - enddo - - if (config_filter_btr_mode) then - ! filter normalBarotropicVelocity out of initial condition - block % state % time_levs(1) % state % normalVelocity % array(:,:) & - = block % state % time_levs(1) % state % normalBaroclinicVelocity % array(:,:) - - block % state % time_levs(1) % state % normalBarotropicVelocity % array(:) = 0.0 - endif - - endif - - block => block % next - end do - - end subroutine ocn_init_split_timestep!}}} - -subroutine ocn_compute_max_level(domain)!{{{ -! Initialize maxLevel and boundary mesh variables. - - use mpas_grid_types - use mpas_configure - use mpas_constants - - implicit none - - type (domain_type), intent(inout) :: domain - - integer :: i, iCell, iEdge, iVertex, k - type (block_type), pointer :: block - - integer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree - - integer, dimension(:), pointer :: & - maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, & - maxLevelVertexTop, maxLevelVertexBot - integer, dimension(:,:), pointer :: & - cellsOnEdge, cellsOnVertex, boundaryEdge, boundaryCell, & - boundaryVertex, verticesOnEdge, edgeMask, cellMask, vertexMask - - ! Initialize z-level mesh variables from h, read in from input file. - block => domain % blocklist - do while (associated(block)) - - maxLevelCell => block % mesh % maxLevelCell % array - maxLevelEdgeTop => block % mesh % maxLevelEdgeTop % array - maxLevelEdgeBot => block % mesh % maxLevelEdgeBot % array - maxLevelVertexTop => block % mesh % maxLevelVertexTop % array - maxLevelVertexBot => block % mesh % maxLevelVertexBot % array - cellsOnEdge => block % mesh % cellsOnEdge % array - cellsOnVertex => block % mesh % cellsOnVertex % array - verticesOnEdge => block % mesh % verticesOnEdge % array - boundaryEdge => block % mesh % boundaryEdge % array - boundaryCell => block % mesh % boundaryCell % array - boundaryVertex => block % mesh % boundaryVertex % array - edgeMask => block % mesh % edgeMask % array - cellMask => block % mesh % cellMask % array - vertexMask => block % mesh % vertexMask % array - - nCells = block % mesh % nCells - nEdges = block % mesh % nEdges - nVertices = block % mesh % nVertices - nVertLevels = block % mesh % nVertLevels - vertexDegree = block % mesh % vertexDegree - - ! maxLevelEdgeTop is the minimum (shallowest) of the surrounding cells - do iEdge=1,nEdges - maxLevelEdgeTop(iEdge) = & - min( maxLevelCell(cellsOnEdge(1,iEdge)), & - maxLevelCell(cellsOnEdge(2,iEdge)) ) - end do - maxLevelEdgeTop(nEdges+1) = 0 - - ! maxLevelEdgeBot is the maximum (deepest) of the surrounding cells - do iEdge=1,nEdges - maxLevelEdgeBot(iEdge) = & - max( maxLevelCell(cellsOnEdge(1,iEdge)), & - maxLevelCell(cellsOnEdge(2,iEdge)) ) - end do - maxLevelEdgeBot(nEdges+1) = 0 - - ! maxLevelVertexBot is the maximum (deepest) of the surrounding cells - do iVertex = 1,nVertices - maxLevelVertexBot(iVertex) = maxLevelCell(cellsOnVertex(1,iVertex)) - do i=2,vertexDegree - maxLevelVertexBot(iVertex) = & - max( maxLevelVertexBot(iVertex), & - maxLevelCell(cellsOnVertex(i,iVertex))) - end do - end do - maxLevelVertexBot(nVertices+1) = 0 - - ! maxLevelVertexTop is the minimum (shallowest) of the surrounding cells - do iVertex = 1,nVertices - maxLevelVertexTop(iVertex) = maxLevelCell(cellsOnVertex(1,iVertex)) - do i=2,vertexDegree - maxLevelVertexTop(iVertex) = & - min( maxLevelVertexTop(iVertex), & - maxLevelCell(cellsOnVertex(i,iVertex))) - end do - end do - maxLevelVertexTop(nVertices+1) = 0 - - ! set boundary edge - boundaryEdge(:,1:nEdges+1)=1 - edgeMask(:,1:nEdges+1)=0 - do iEdge=1,nEdges - boundaryEdge(1:maxLevelEdgeTop(iEdge),iEdge)=0 - edgeMask(1:maxLevelEdgeTop(iEdge),iEdge)=1 - end do - - ! - ! Find cells and vertices that have an edge on the boundary - ! - boundaryCell(:,1:nCells+1) = 0 - cellMask(:,1:nCells+1) = 0 - boundaryVertex(:,1:nVertices+1) = 0 - vertexMask(:,1:nVertices+1) = 0 - do iEdge=1,nEdges - do k=1,nVertLevels - if (boundaryEdge(k,iEdge).eq.1) then - boundaryCell(k,cellsOnEdge(1,iEdge)) = 1 - boundaryCell(k,cellsOnEdge(2,iEdge)) = 1 - boundaryVertex(k,verticesOnEdge(1,iEdge)) = 1 - boundaryVertex(k,verticesOnEdge(2,iEdge)) = 1 - endif - end do - end do - - do iCell = 1, nCells - do k = 1, nVertLevels - if ( maxLevelCell(iCell) >= k ) then - cellMask(k, iCell) = 1 - end if - end do - end do - - do iVertex = 1, nVertices - do k = 1, nVertLevels - if ( maxLevelVertexBot(iVertex) >= k ) then - vertexMask(k, iVertex) = 1 - end if - end do - end do - - block => block % next - end do - - ! Note: We do not update halos on maxLevel* variables. I want the - ! outside edge of a halo to be zero on each processor. - -end subroutine ocn_compute_max_level!}}} - - subroutine mpas_core_finalize(domain)!{{{ - - use mpas_grid_types - - implicit none - - type (domain_type), intent(inout) :: domain - integer :: ierr - - call mpas_destroy_clock(clock, ierr) - - end subroutine mpas_core_finalize!}}} - - subroutine ocn_compute_mesh_scaling(mesh)!{{{ - - use mpas_grid_types - use mpas_configure - - implicit none - - type (mesh_type), intent(inout) :: mesh - - integer :: iEdge, cell1, cell2 - real (kind=RKIND), dimension(:), pointer :: meshDensity, meshScalingDel2, meshScalingDel4, meshScaling - - meshDensity => mesh % meshDensity % array - meshScalingDel2 => mesh % meshScalingDel2 % array - meshScalingDel4 => mesh % meshScalingDel4 % array - meshScaling => mesh % meshScaling % array - - ! - ! Compute the scaling factors to be used in the del2 and del4 dissipation - ! - meshScalingDel2(:) = 1.0 - meshScalingDel4(:) = 1.0 - meshScaling(:) = 1.0 - if (config_hmix_ScaleWithMesh) then - do iEdge=1,mesh%nEdges - cell1 = mesh % cellsOnEdge % array(1,iEdge) - cell2 = mesh % cellsOnEdge % array(2,iEdge) - meshScalingDel2(iEdge) = 1.0 / ( ((meshDensity(cell1) + meshDensity(cell2) )/2.0)/config_maxMeshDensity)**(3.0/4.0) ! goes as dc**3 - meshScalingDel4(iEdge) = 1.0 / ( ((meshDensity(cell1) + meshDensity(cell2) )/2.0)/config_maxMeshDensity)**(3.0/4.0) ! goes as dc**3 - meshScaling(iEdge) = 1.0 / ( ((meshDensity(cell1) + meshDensity(cell2) )/2.0)/config_maxMeshDensity)**(1.0/4.0) - end do - end if - - 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!}}} - - -!*********************************************************************** -! -! routine mpas_core_setup_packages -! -!> \brief Pacakge setup routine -!> \author Doug Jacobsen -!> \date September 2011 -!> \details -!> This routine is intended to correctly configure the packages for this MPAS -!> core. It can use any Fortran logic to properly configure packages, and it -!> can also make use of any namelist options. All variables in the model are -!> *not* allocated until after this routine is called. -! -!----------------------------------------------------------------------- - subroutine mpas_core_setup_packages(ierr)!{{{ - - use mpas_packages - - implicit none - - integer, intent(out) :: ierr - - ierr = 0 - - end subroutine mpas_core_setup_packages!}}} - -end module mpas_core - -! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_tendency.F b/src/core_ocean/mpas_ocn_tendency.F deleted file mode 100644 index 500557cd9b..0000000000 --- a/src/core_ocean/mpas_ocn_tendency.F +++ /dev/null @@ -1,513 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_tendency -! -!> \brief MPAS ocean tendency driver -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date September 2011 -!> \details -!> This module contains the routines for computing -!> tendency terms for the ocean primitive equations. -! -!----------------------------------------------------------------------- - -module ocn_tendency - - use mpas_grid_types - use mpas_configure - use mpas_constants - use mpas_timer - - use ocn_tracer_advection - use ocn_tracer_short_wave_absorption - - use ocn_thick_hadv - use ocn_thick_vadv - use ocn_thick_surface_flux - - 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_hmix - use ocn_high_freq_thickness_hmix_del2 - use ocn_tracer_surface_flux - - implicit none - private - save - - type (timer_node), pointer :: thickHadvTimer, thickVadvTimer - type (timer_node), pointer :: velCorTimer, velVadvTimer, velPgradTimer, velHmixTimer, velForceTimer - type (timer_node), pointer :: tracerHadvTimer, tracerVadvTimer, tracerHmixTimer, tracerRestoringTimer - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_tend_thick, & - ocn_tend_vel, & - ocn_tend_tracer, & - ocn_tend_freq_filtered_thickness, & - ocn_tendency_init - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - integer :: apply_Dhf_to_hhf, use_highFreqThick_restore - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_tend_thick -! -!> \brief Computes thickness tendency -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine computes the thickness tendency for the ocean -! -!----------------------------------------------------------------------- - - subroutine ocn_tend_thick(tend, state, forcing, diagnostics, mesh)!{{{ - implicit none - - type (tend_type), intent(inout) :: tend !< Input/Output: Tendency structure - !DWJ 09/25/2013: Remove State if it's really not needed here. - type (state_type), intent(in) :: state !< Input: State information - type (forcing_type), intent(in) :: forcing !< Input: Forcing information - type (diagnostics_type), intent(in) :: diagnostics !< Input: Diagnostics information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - - real (kind=RKIND), dimension(:), pointer :: surfaceMassFlux - real (kind=RKIND), dimension(:,:), pointer :: layerThickness, layerThicknessEdge, vertTransportVelocityTop, tend_layerThickness, uTransport, transmissionCoefficients - - integer :: err - - call mpas_timer_start("ocn_tend_thick") - - uTransport => diagnostics % uTransport % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - vertTransportVelocityTop => diagnostics % vertTransportVelocityTop % array - - tend_layerThickness => tend % layerThickness % array - - surfaceMassFlux => forcing % surfaceMassFlux % array - transmissionCoefficients => forcing % transmissionCoefficients % array - - ! - ! height tendency: start accumulating tendency terms - ! - tend_layerThickness = 0.0 - - if(config_disable_thick_all_tend) return - - ! - ! height tendency: horizontal advection term -\nabla\cdot ( hu) - ! - ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3. - ! for explanation of divergence operator. - ! - ! QC Comment (3/15/12): need to make sure that uTranport is the right - ! transport velocity here. - call mpas_timer_start("hadv", .false., thickHadvTimer) - call ocn_thick_hadv_tend(mesh, uTransport, layerThicknessEdge, tend_layerThickness, err) - call mpas_timer_stop("hadv", thickHadvTimer) - - ! - ! height tendency: vertical advection term -d/dz(hw) - ! - call mpas_timer_start("vadv", .false., thickVadvTimer) - call ocn_thick_vadv_tend(mesh, vertTransportVelocityTop, tend_layerThickness, err) - call mpas_timer_stop("vadv", thickVadvTimer) - - ! - ! surface flux tendency - ! - call mpas_timer_start("surface flux", .false.) - call ocn_thick_surface_flux_tend(mesh, transmissionCoefficients, layerThickness, surfaceMassFlux, tend_layerThickness, err) - call mpas_timer_stop("surface flux") - - call mpas_timer_stop("ocn_tend_thick") - - end subroutine ocn_tend_thick!}}} - -!*********************************************************************** -! -! routine ocn_tend_vel -! -!> \brief Computes velocity tendency -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine computes the velocity tendency for the ocean -! -!----------------------------------------------------------------------- - - subroutine ocn_tend_vel(tend, state, forcing, diagnostics, mesh, scratch)!{{{ - implicit none - - type (tend_type), intent(inout) :: tend !< Input/Output: Tendency structure - type (state_type), intent(in) :: state !< Input: State information - type (forcing_type), intent(in) :: forcing !< Input: Forcing information - type (diagnostics_type), intent(in) :: diagnostics !< Input: Diagnostic information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - type (scratch_type), intent(inout) :: scratch !< Input: Scratch structure - - real (kind=RKIND), dimension(:), pointer :: surfaceWindStress - - real (kind=RKIND), dimension(:,:), pointer :: & - layerThicknessEdge, normalVelocity, tangentialVelocity, density, zMid, pressure, & - tend_normalVelocity, circulation, relativeVorticity, viscosity, kineticEnergyCell, & - normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, & - montgomeryPotential, vertTransportVelocityTop, divergence, vertViscTopOfEdge - - integer :: err - - call mpas_timer_start("ocn_tend_vel") - - normalVelocity => state % normalVelocity % array - - kineticEnergyCell => diagnostics % kineticEnergyCell % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - vertTransportVelocityTop => diagnostics % vertTransportVelocityTop % array - zMid => diagnostics % zMid % array - relativeVorticity => diagnostics % relativeVorticity % array - normalizedRelativeVorticityEdge => diagnostics % normalizedRelativeVorticityEdge % array - normalizedPlanetaryVorticityEdge => diagnostics % normalizedPlanetaryVorticityEdge % array - divergence => diagnostics % divergence % array - viscosity => diagnostics % viscosity % array - montgomeryPotential => diagnostics % montgomeryPotential % array - pressure => diagnostics % pressure % array - vertViscTopOfEdge => diagnostics % vertViscTopOfEdge % array - density => diagnostics % density % array - tangentialVelocity => diagnostics % tangentialVelocity % array - - tend_normalVelocity => tend % normalVelocity % array - - surfaceWindStress => forcing % surfaceWindStress % array - - ! - ! velocity tendency: start accumulating tendency terms - ! - tend_normalVelocity(:,:) = 0.0 - - if(config_disable_vel_all_tend) return - - ! - ! velocity tendency: nonlinear Coriolis term and grad of kinetic energy - ! - - call mpas_timer_start("coriolis", .false., velCorTimer) - call ocn_vel_coriolis_tend(mesh, normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, layerThicknessEdge, & - normalVelocity, kineticEnergyCell, tend_normalVelocity, err) - call mpas_timer_stop("coriolis", velCorTimer) - - ! - ! velocity tendency: vertical advection term -w du/dz - ! - call mpas_timer_start("vadv", .false., velVadvTimer) - call ocn_vel_vadv_tend(mesh, normalVelocity, layerThicknessEdge, vertTransportVelocityTop, tend_normalVelocity, err) - call mpas_timer_stop("vadv", velVadvTimer) - - ! - ! velocity tendency: pressure gradient - ! - call mpas_timer_start("pressure grad", .false., velPgradTimer) - if (config_pressure_gradient_type.eq.'MontgomeryPotential') then - call ocn_vel_pressure_grad_tend(mesh, montgomeryPotential, zMid, density, tend_normalVelocity, err) - else - call ocn_vel_pressure_grad_tend(mesh, pressure, zMid, density, tend_normalVelocity, err) - end if - call mpas_timer_stop("pressure grad", velPgradTimer) - - ! - ! velocity tendency: del2 dissipation, \nu_2 \nabla^2 u - ! computed as \nu( \nabla divergence + k \times \nabla relativeVorticity ) - ! strictly only valid for config_mom_del2 == constant - ! - call mpas_timer_start("hmix", .false., velHmixTimer) - call ocn_vel_hmix_tend(mesh, divergence, relativeVorticity, normalVelocity, tangentialVelocity, viscosity, & - tend_normalVelocity, scratch, err) - call mpas_timer_stop("hmix", velHmixTimer) - - ! - ! velocity tendency: forcing and bottom drag - ! - - call mpas_timer_start("forcings", .false., velForceTimer) - call ocn_vel_forcing_tend(mesh, normalVelocity, surfaceWindStress, layerThicknessEdge, tend_normalVelocity, err) - call mpas_timer_stop("forcings", velForceTimer) - - ! - ! velocity tendency: vertical mixing d/dz( nu_v du/dz)) - ! - call mpas_timer_stop("ocn_tend_vel") - - end subroutine ocn_tend_vel!}}} - -!*********************************************************************** -! -! routine ocn_tend_tracer -! -!> \brief Computes tracer tendency -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine computes tracer tendencies for the ocean -! -!----------------------------------------------------------------------- - subroutine ocn_tend_tracer(tend, state, forcing, diagnostics, mesh, dt)!{{{ - implicit none - - type (tend_type), intent(inout) :: tend !< Input/Output: Tendency structure - type (state_type), intent(in) :: state !< Input: State information - type (forcing_type), intent(in) :: forcing !< Input: Forcing information - type (diagnostics_type), intent(in) :: diagnostics !< Input: Diagnostic information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - real (kind=RKIND), intent(in) :: dt !< Input: Time step - - real (kind=RKIND), dimension(:), pointer :: penetrativeTemperatureFlux - real (kind=RKIND), dimension(:,:), pointer :: & - uTransport, layerThickness,vertTransportVelocityTop, layerThicknessEdge, vertDiffTopOfCell, tend_layerThickness, normalThicknessFlux, surfaceTracerFlux, transmissionCoefficients - real (kind=RKIND), dimension(:,:,:), pointer :: & - tracers, tend_tr - - integer :: err, iEdge, k - - call mpas_timer_start("ocn_tend_tracer") - - layerThickness => state % layerThickness % array - tracers => state % tracers % array - - uTransport => diagnostics % uTransport % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - vertDiffTopOfCell => diagnostics % vertDiffTopOfCell % array - vertTransportVelocityTop => diagnostics % vertTransportVelocityTop % array - - penetrativeTemperatureFlux => forcing % penetrativeTemperatureFlux % array - surfaceTracerFlux => forcing % surfaceTracerFlux % array - transmissionCoefficients => forcing % transmissionCoefficients % array - - tend_tr => tend % tracers % array - tend_layerThickness => tend % layerThickness % array - - ! - ! initialize tracer tendency (RHS of tracer equation) to zero. - ! - tend_tr(:,:,:) = 0.0 - - if(config_disable_tr_all_tend) return - - allocate(normalThicknessFlux(mesh % nVertLevels, mesh % nEdges+1)) - ! - ! QC Comment (3/15/12): need to make sure that uTransport is the right - ! transport velocity for the tracer. - do iEdge = 1, mesh % nEdges - do k = 1, mesh % nVertLevels - normalThicknessFlux(k, iEdge) = uTransport(k, iEdge) * layerThicknessEdge(k, iEdge) - end do - end do - - ! - ! tracer tendency: horizontal advection term -div( layerThickness \phi u) - ! - - ! Monotonoic Advection, or standard advection - call mpas_timer_start("adv", .false., tracerHadvTimer) - call ocn_tracer_advection_tend(tracers, normalThicknessFlux, vertTransportVelocityTop, layerThickness, layerThickness, dt, mesh, tend_layerThickness, tend_tr) - call mpas_timer_stop("adv", tracerHadvTimer) - - ! - ! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 \nabla \phi) - ! - call mpas_timer_start("hmix", .false., tracerHmixTimer) - call ocn_tracer_hmix_tend(mesh, layerThicknessEdge, tracers, tend_tr, err) - call mpas_timer_stop("hmix", tracerHmixTimer) - - ! - ! Perform forcing from surface fluxes - ! - call mpas_timer_start("surface_flux", .false.) - call ocn_tracer_surface_flux_tend(mesh, transmissionCoefficients, layerThickness, surfaceTracerFlux, tend_tr, err) - call mpas_timer_stop("surface_flux") - - ! - ! Performing shortwave absorption - ! - call mpas_timer_start("short wave", .false.) - call ocn_tracer_short_wave_absorption_tend(mesh, state % index_temperature, layerThickness, penetrativeTemperatureFlux, tend_tr, err) - call mpas_timer_stop("short wave") - - call mpas_timer_stop("ocn_tend_tracer") - - deallocate(normalThicknessFlux) - - end subroutine ocn_tend_tracer!}}} - -!*********************************************************************** -! -! routine ocn_tend_freq_filtered_thickness -! -!> \brief Compute tendencies needed for frequency filtered thickness -!> \author Mark Petersen -!> \date July 2013 -!> \details -!> This routine compute high frequency thickness tendency and the -!> low freqency divergence. It is only called when -!> config_freq_filtered_thickness is true (z-tilde) -! -!----------------------------------------------------------------------- - subroutine ocn_tend_freq_filtered_thickness(tend, state, diagnostics, mesh)!{{{ - - type (tend_type), intent(inout) :: tend !< Input/Output: Tendency information - type (state_type), intent(in) :: state !< Input: State information - type (diagnostics_type), intent(in) :: diagnostics !< Input: Diagnostics information - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - - integer :: err, nCells, nVertLevels, iCell, i, k, iEdge - integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeBot, nEdgesOnCell - integer, dimension(:,:), pointer :: edgesOnCell, edgeSignOnCell - - real (kind=RKIND) :: flux, invAreaCell, div_hu_btr, thickness_filter_timescale_sec, highFreqThick_restore_time_sec, & - totalThickness - real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell - real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, layerThicknessEdge, & - layerThickness, & - lowFreqDivergence, highFreqThickness, & - tend_lowFreqDivergence, tend_highFreqThickness - real (kind=RKIND), dimension(:), allocatable:: div_hu - - call mpas_timer_start("ocn_tend_freq_filtered_thickness") - err = 0 - - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels - - nEdgesOnCell => mesh % nEdgesOnCell % array - areaCell => mesh % areaCell % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnCell => mesh % edgeSignOnCell % array - maxLevelCell => mesh % maxLevelCell % array - maxLevelEdgeBot => mesh % maxLevelEdgeBot % array - dvEdge => mesh % dvEdge % array - - normalVelocity => state % normalVelocity % array - layerThickness => state % layerThickness % array - lowFreqDivergence => state % lowFreqDivergence % array - highFreqThickness => state % highFreqThickness % array - - layerThicknessEdge => diagnostics % layerThicknessEdge % array - - tend_lowFreqDivergence => tend % lowFreqDivergence % array - tend_highFreqThickness => tend % highFreqThickness % array - - allocate(div_hu(nVertLevels)) - - ! - ! Low Frequency Divergence and high frequency thickness Tendency - ! - tend_lowFreqDivergence = 0.0 - tend_highFreqThickness = 0.0 - - ! Convert restore time from days to seconds - thickness_filter_timescale_sec = config_thickness_filter_timescale*86400.0 - highFreqThick_restore_time_sec = config_highFreqThick_restore_time*86400.0 - do iCell=1,nCells - div_hu(:) = 0.0 - div_hu_btr = 0.0 - invAreaCell = 1.0 / areaCell(iCell) - - do i = 1, nEdgesOnCell(iCell) - iEdge = edgesOnCell(i, iCell) - - do k = 1, maxLevelEdgeBot(iEdge) - flux = layerThicknessEdge(k, iEdge) * normalVelocity(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 - - totalThickness = sum(layerThickness(1:maxLevelCell(iCell),iCell)) - do k = 1, maxLevelCell(iCell) - - tend_lowFreqDivergence(k,iCell) = & - -2.0*pii/thickness_filter_timescale_sec & - *(lowFreqDivergence(k,iCell) - div_hu(k) & - + div_hu_btr*layerThickness(k,iCell)/totalThickness) - - tend_highFreqThickness(k,iCell) = & - - div_hu(k) + div_hu_btr*layerThickness(k,iCell)/totalThickness + lowFreqDivergence(k,iCell) & - + use_highFreqThick_restore*( -2.0*pii/highFreqThick_restore_time_sec * highFreqThickness(k,iCell) ) - - end do - - end do - - deallocate(div_hu) - - ! - ! high frequency thickness tendency: del2 horizontal hhf diffusion, div(\kappa_{hf} \nabla h^{hf}) - ! - call mpas_timer_start("hmix", .false., tracerHmixTimer) - call ocn_high_freq_thickness_hmix_del2_tend(mesh, highFreqThickness, tend_highFreqThickness, err) - call mpas_timer_stop("hmix", tracerHmixTimer) - - call mpas_timer_stop("ocn_tend_freq_filtered_thickness") - - end subroutine ocn_tend_freq_filtered_thickness!}}} - -!*********************************************************************** -! -! routine ocn_tendency_init -! -!> \brief Initializes flags used within tendency routines. -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date 4 November 2011 -!> \details -!> This routine initializes flags related to quantities computed within -!> other tendency routines. -! -!----------------------------------------------------------------------- - subroutine ocn_tendency_init(err)!{{{ - integer, intent(out) :: err !< Output: Error flag - - err = 0 - if (config_use_highFreqThick_restore) then - use_highFreqThick_restore = 1 - else - use_highFreqThick_restore = 0 - endif - - end subroutine ocn_tendency_init!}}} - -!*********************************************************************** - -end module ocn_tendency - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_test.F b/src/core_ocean/mpas_ocn_test.F deleted file mode 100644 index 9319d6be6b..0000000000 --- a/src/core_ocean/mpas_ocn_test.F +++ /dev/null @@ -1,191 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_test -! -!> \brief Driver for testing MPAS ocean core -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date October 2013 -!> \details -!> This module contains routines to test various components of -!> the MPAS ocean core. -! -!----------------------------------------------------------------------- - -module ocn_test - - use mpas_configure - use mpas_framework - use mpas_timekeeping - use mpas_dmpar - use mpas_timer - use mpas_tensor_operations - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_test_suite - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - logical :: hmixOn - type (timer_node), pointer :: del2Timer, del2TensorTimer, leithTimer, del4Timer, del4TensorTimer - - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_test_suite -! -!> \brief Call all internal start-up tests -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date October 2013 -!> \details -!> Call all routines to test various MPAS-Ocean components. -! -!----------------------------------------------------------------------- - - subroutine ocn_test_suite(domain, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - - type (domain_type), intent(inout) :: domain - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - integer :: err1 - - err=0 - - call ocn_prep_test_tensor(domain,err1) - err = ior(err1,err) - - end subroutine ocn_test_suite!}}} - - -!*********************************************************************** -! -! routine ocn_prep_test_tensor -! -!> \brief set up scratch variables to test strain rate and tensor divergence operators -!> \author Mark Petersen -!> \date May 2013 -!> \details -!> This routine sets up scratch variables to test strain rate and tensor divergence operators. -! -!----------------------------------------------------------------------- - - subroutine ocn_prep_test_tensor(domain,err)!{{{ - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - - type (domain_type), intent(inout) :: domain - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - if (.not.config_test_tensors) return - - call mpas_allocate_scratch_field(domain % blocklist % scratch % normalVelocityTest, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % tangentialVelocityTest, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % strainRateR3Cell, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % strainRateR3CellSolution, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % strainRateR3Edge, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % strainRateLonLatRCell, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % strainRateLonLatRCellSolution, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % strainRateLonLatREdge, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % divTensorR3Cell, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % divTensorR3CellSolution, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % divTensorLonLatRCell, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % divTensorLonLatRCellSolution, .false.) - call mpas_allocate_scratch_field(domain % blocklist % scratch % outerProductEdge, .false.) - - call mpas_test_tensor(domain, config_tensor_test_function, & - domain % blocklist % mesh % edgeSignOnCell, & - domain % blocklist % mesh % edgeTangentVectors, & - domain % blocklist % scratch % normalVelocityTest, & - domain % blocklist % scratch % tangentialVelocityTest, & - domain % blocklist % scratch % strainRateR3Cell, & - domain % blocklist % scratch % strainRateR3CellSolution, & - domain % blocklist % scratch % strainRateR3Edge, & - domain % blocklist % scratch % strainRateLonLatRCell, & - domain % blocklist % scratch % strainRateLonLatRCellSolution, & - domain % blocklist % scratch % strainRateLonLatREdge, & - domain % blocklist % scratch % divTensorR3Cell, & - domain % blocklist % scratch % divTensorR3CellSolution, & - domain % blocklist % scratch % divTensorLonLatRCell, & - domain % blocklist % scratch % divTensorLonLatRCellSolution, & - domain % blocklist % scratch % outerProductEdge ) - - call mpas_deallocate_scratch_field(domain % blocklist % scratch % normalVelocityTest, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % tangentialVelocityTest, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % strainRateR3Cell, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % strainRateR3CellSolution, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % strainRateR3Edge, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % strainRateLonLatRCell, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % strainRateLonLatRCellSolution, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % strainRateLonLatREdge, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % divTensorR3Cell, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % divTensorR3CellSolution, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % divTensorLonLatRCell, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % divTensorLonLatRCellSolution, .false.) - call mpas_deallocate_scratch_field(domain % blocklist % scratch % outerProductEdge, .false.) - - err = 0 - - end subroutine ocn_prep_test_tensor!}}} - -end module ocn_test - -! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_time_average.F b/src/core_ocean/mpas_ocn_time_average.F deleted file mode 100644 index aee4da8bf6..0000000000 --- a/src/core_ocean/mpas_ocn_time_average.F +++ /dev/null @@ -1,139 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -module ocn_time_average - - use mpas_grid_types - - implicit none - save - public - - contains - - subroutine ocn_time_average_init(average)!{{{ - type (average_type), intent(inout) :: average - - real (kind=RKIND), pointer :: nAverage - - real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH - real (kind=RKIND), dimension(:,:), pointer :: avgVelocityZonal, avgVelocityMeridional, varVelocityZonal, varVelocityMeridional - real (kind=RKIND), dimension(:,:), pointer :: avgNormalVelocity, varNormalVelocity, avgVertVelocityTop - - nAverage => average % nAverage % scalar - - avgSSH => average % avgSSH % array - varSSH => average % varSSH % array - avgVelocityZonal => average % avgVelocityZonal % array - avgVelocityMeridional => average % avgVelocityMeridional % array - varVelocityZonal => average % varVelocityZonal % array - varVelocityMeridional => average % varVelocityMeridional % array - avgNormalVelocity => average % avgNormalVelocity % array - varNormalVelocity => average % varNormalVelocity % array - avgVertVelocityTop => average % avgVertVelocityTop % array - - nAverage = 0 - - avgSSH = 0.0 - varSSH = 0.0 - avgVelocityZonal = 0.0 - avgVelocityMeridional = 0.0 - varVelocityZonal = 0.0 - varVelocityMeridional = 0.0 - avgNormalVelocity = 0.0 - varNormalVelocity = 0.0 - avgVertVelocityTop = 0.0 - - end subroutine ocn_time_average_init!}}} - - subroutine ocn_time_average_accumulate(average, state, diagnostics)!{{{ - type (average_type), intent(inout) :: average - type (state_type), intent(in) :: state - type (diagnostics_type), intent(in) :: diagnostics - - real (kind=RKIND), pointer :: nAverage, old_nAverage - - real (kind=RKIND), dimension(:), pointer :: ssh - real (kind=RKIND), dimension(:,:), pointer :: normalVelocityZonal, normalVelocityMeridional, normalVelocity, vertVelocityTop - - real (kind=RKIND), dimension(:,:), pointer :: avgNormalVelocity, varNormalVelocity, avgVertVelocityTop - real (kind=RKIND), dimension(:,:), pointer :: avgVelocityZonal, avgVelocityMeridional, varVelocityZonal, varVelocityMeridional - real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH - - real (kind=RKIND), dimension(:,:), pointer :: old_avgNormalVelocity, old_varNormalVelocity, old_avgVertVelocityTop - real (kind=RKIND), dimension(:,:), pointer :: old_avgVelocityZonal, old_avgVelocityMeridional, old_varVelocityZonal, old_varVelocityMeridional - real (kind=RKIND), dimension(:), pointer :: old_avgSSH, old_varSSH - - nAverage => average % nAverage % scalar - - normalVelocity => state % normalVelocity % array - ssh => state % ssh % array - - normalVelocityZonal => diagnostics % normalVelocityZonal % array - normalVelocityMeridional => diagnostics % normalVelocityMeridional % array - vertVelocityTop => diagnostics % vertVelocityTop % array - - avgSSH => average % avgSSH % array - varSSH => average % varSSH % array - avgVelocityZonal => average % avgVelocityZonal % array - avgVelocityMeridional => average % avgVelocityMeridional % array - varVelocityZonal => average % varVelocityZonal % array - varVelocityMeridional => average % varVelocityMeridional % array - avgNormalVelocity => average % avgNormalVelocity % array - varNormalVelocity => average % varNormalVelocity % array - avgVertVelocityTop => average % avgVertVelocityTop % array - - avgSSH = avgSSH + ssh - varSSH = varSSH + ssh**2 - avgVelocityZonal = avgVelocityZonal + normalVelocityZonal - avgVelocityMeridional = avgVelocityMeridional + normalVelocityMeridional - varVelocityZonal = varVelocityZonal + normalVelocityZonal**2 - varVelocityMeridional = varVelocityMeridional + normalVelocityMeridional**2 - avgNormalVelocity = avgNormalVelocity + normalVelocity - varNormalVelocity = varNormalVelocity + normalVelocity**2 - avgVertVelocityTop = avgVertVelocityTop + vertVelocityTop - - nAverage = nAverage + 1 - end subroutine ocn_time_average_accumulate!}}} - - subroutine ocn_time_average_normalize(average)!{{{ - type (average_type), intent(inout) :: average - - real (kind=RKIND), pointer :: nAverage - - real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH - real (kind=RKIND), dimension(:,:), pointer :: avgVelocityZonal, avgVelocityMeridional, varVelocityZonal, varVelocityMeridional - real (kind=RKIND), dimension(:,:), pointer :: avgNormalVelocity, varNormalVelocity, avgVertVelocityTop - - nAverage => average % nAverage % scalar - - avgSSH => average % avgSSH % array - varSSH => average % varSSH % array - avgVelocityZonal => average % avgVelocityZonal % array - avgVelocityMeridional => average % avgVelocityMeridional % array - varVelocityZonal => average % varVelocityZonal % array - varVelocityMeridional => average % varVelocityMeridional % array - avgNormalVelocity => average % avgNormalVelocity % array - varNormalVelocity => average % varNormalVelocity % array - avgVertVelocityTop => average % avgVertVelocityTop % array - - if(nAverage > 0) then - avgSSH = avgSSH / nAverage - varSSH = varSSH / nAverage - avgVelocityZonal = avgVelocityZonal / nAverage - avgVelocityMeridional = avgVelocityMeridional / nAverage - varVelocityZonal = varVelocityZonal / nAverage - varVelocityMeridional = varVelocityMeridional / nAverage - avgNormalVelocity = avgNormalVelocity / nAverage - varNormalVelocity = varNormalVelocity / nAverage - avgVertVelocityTop = avgVertVelocityTop / nAverage - - nAverage = 0 - end if - end subroutine ocn_time_average_normalize!}}} - -end module ocn_time_average diff --git a/src/core_ocean/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mpas_ocn_time_integration_rk4.F deleted file mode 100644 index 2bbfa8d265..0000000000 --- a/src/core_ocean/mpas_ocn_time_integration_rk4.F +++ /dev/null @@ -1,418 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_time_integration_rk4 -! -!> \brief MPAS ocean RK4 Time integration scheme -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date September 2011 -!> \details -!> This module contains the RK4 time integration routine. -! -!----------------------------------------------------------------------- - -module ocn_time_integration_rk4 - - use mpas_grid_types - use mpas_configure - use mpas_constants - use mpas_dmpar - use mpas_vector_reconstruction - use mpas_spline_interpolation - use mpas_timer - - use ocn_tendency - use ocn_diagnostics - - use ocn_equation_of_state - use ocn_vmix - use ocn_time_average - use ocn_time_average_coupled - use ocn_sea_ice - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_time_integrator_rk4 - - contains - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_time_integrator_rk4 -! -!> \brief MPAS ocean RK4 Time integration scheme -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine integrates one timestep (dt) using an RK4 time integrator. -! -!----------------------------------------------------------------------- - - subroutine ocn_time_integrator_rk4(domain, dt)!{{{ - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Advance model state forward in time by the specified time step using - ! 4th order Runge-Kutta - ! - ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:)) - ! plus mesh meta-data - ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains - ! model state advanced forward in time by dt seconds - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - implicit none - - type (domain_type), intent(inout) :: domain !< Input/Output: domain information - real (kind=RKIND), intent(in) :: dt !< Input: timestep - - integer :: iCell, k, i, err - type (block_type), pointer :: block - - integer :: rk_step - - real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights - - integer :: nCells, nEdges, nVertLevels, num_tracers - real (kind=RKIND) :: coef - real (kind=RKIND), dimension(:,:), pointer :: & - u, layerThickness, layerThicknessEdge, vertViscTopOfEdge, vertDiffTopOfCell - real (kind=RKIND), dimension(:,:,:), pointer :: tracers - integer, dimension(:), pointer :: & - maxLevelCell, maxLevelEdgeTop - real (kind=RKIND), dimension(:), allocatable:: A,C,uTemp - real (kind=RKIND), dimension(:,:), allocatable:: tracersTemp - - call mpas_setup_provis_state(domain % blocklist) - - ! - ! Initialize time_levs(2) with state at current time - ! Initialize first RK state - ! Couple tracers time_levs(2) with layerThickness in time-levels - ! Initialize RK weights - ! - block => domain % blocklist - do while (associated(block)) - - block % state % time_levs(2) % state % normalVelocity % array(:,:) = block % state % time_levs(1) % state % normalVelocity % array(:,:) - block % state % time_levs(2) % state % layerThickness % array(:,:) = block % state % time_levs(1) % state % layerThickness % array(:,:) - - do iCell=1,block % mesh % nCells ! couple tracers to thickness - do k=1,block % mesh % maxLevelCell % array(iCell) - block % state % time_levs(2) % state % tracers % array(:,k,iCell) = block % state % time_levs(1) % state % tracers % array(:,k,iCell) & - * block % state % time_levs(1) % state % layerThickness % array(k,iCell) - end do - end do - - if (config_use_freq_filtered_thickness) then - block % state % time_levs(2) % state % highFreqThickness % array(:,:) = block % state % time_levs(1) % state % highFreqThickness % array(:,:) - block % state % time_levs(2) % state % lowFreqDivergence % array(:,:) = block % state % time_levs(1) % state % lowFreqDivergence % array(:,:) - endif - - call mpas_copy_state(block % provis_state, block % state % time_levs(1) % state) - - block => block % next - end do - - rk_weights(1) = dt/6. - rk_weights(2) = dt/3. - rk_weights(3) = dt/3. - rk_weights(4) = dt/6. - - rk_substep_weights(1) = dt/2. - rk_substep_weights(2) = dt/2. - rk_substep_weights(3) = dt - rk_substep_weights(4) = dt ! a_4 only used for ALE step, otherwise it is skipped. - - - call mpas_timer_start("RK4-main loop") - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! BEGIN RK loop - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do rk_step = 1, 4 -! --- update halos for diagnostic variables - - call mpas_timer_start("RK4-diagnostic halo update") - call mpas_dmpar_exch_halo_field(domain % blocklist % diagnostics % normalizedRelativeVorticityEdge) - if (config_mom_del4 > 0.0) then - call mpas_dmpar_exch_halo_field(domain % blocklist % diagnostics % divergence) - call mpas_dmpar_exch_halo_field(domain % blocklist % diagnostics % relativeVorticity) - end if - call mpas_timer_stop("RK4-diagnostic halo update") - -! --- compute tendencies - - if (config_use_freq_filtered_thickness) then - call mpas_timer_start("RK4-tendency computations") - block => domain % blocklist - do while (associated(block)) - call ocn_tend_freq_filtered_thickness(block % tend, block % provis_state, block % diagnostics, block % mesh) - block => block % next - end do - call mpas_timer_stop("RK4-tendency computations") - - call mpas_timer_start("RK4-prognostic halo update") - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % highFreqThickness) - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % lowFreqDivergence) - call mpas_timer_stop("RK4-prognostic halo update") - - - block => domain % blocklist - do while (associated(block)) - block % provis_state % highFreqThickness % array(:,:) = block % state % time_levs(1) % state % highFreqThickness % array(:,:) & - + rk_substep_weights(rk_step) * block % tend % highFreqThickness % array(:,:) - block => block % next - end do - - endif - - call mpas_timer_start("RK4-tendency computations") - block => domain % blocklist - do while (associated(block)) - - ! advection of u uses u, while advection of layerThickness and tracers use uTransport. - call ocn_vert_transport_velocity_top(block % mesh, block % verticalMesh, & - block % state % time_levs(1) % state % layerThickness % array, & - block % diagnostics % layerThicknessEdge % array, block % provis_state % normalVelocity % array, & - block % state % time_levs(1) % state % ssh % array, block % provis_state % highFreqThickness % array, & - rk_substep_weights(rk_step), block % diagnostics % vertTransportVelocityTop % array, err) - - call ocn_tend_vel(block % tend, block % provis_state, block % forcing, block % diagnostics, block % mesh, block % scratch) - - call ocn_vert_transport_velocity_top(block % mesh, block % verticalMesh, & - block % state % time_levs(1) % state % layerThickness % array, & - block % diagnostics % layerThicknessEdge % array, block % diagnostics % uTransport % array, & - block % state % time_levs(1) % state % ssh % array, block % provis_state % highFreqThickness % array, & - rk_substep_weights(rk_step), block % diagnostics % vertTransportVelocityTop % array, err) - - call ocn_tend_thick(block % tend, block % provis_state, block % forcing, block % diagnostics, block % mesh) - - if (config_filter_btr_mode) then - call ocn_filter_btr_mode_tend_vel(block % tend, block % provis_state, block % diagnostics, block % mesh) - endif - - call ocn_tend_tracer(block % tend, block % provis_state, block % forcing, block % diagnostics, block % mesh, dt) - block => block % next - end do - call mpas_timer_stop("RK4-tendency computations") - -! --- update halos for prognostic variables - - call mpas_timer_start("RK4-prognostic halo update") - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % normalVelocity) - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % layerThickness) - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % tracers) - call mpas_timer_stop("RK4-prognostic halo update") - -! --- compute next substep state - - call mpas_timer_start("RK4-update diagnostic variables") - if (rk_step < 4) then - block => domain % blocklist - do while (associated(block)) - - block % provis_state % normalVelocity % array(:,:) = block % state % time_levs(1) % state % normalVelocity % array(:,:) & - + rk_substep_weights(rk_step) * block % tend % normalVelocity % array(:,:) - - block % provis_state % layerThickness % array(:,:) = block % state % time_levs(1) % state % layerThickness % array(:,:) & - + rk_substep_weights(rk_step) * block % tend % layerThickness % array(:,:) - do iCell=1,block % mesh % nCells - do k=1,block % mesh % maxLevelCell % array(iCell) - block % provis_state % tracers % array(:,k,iCell) = ( block % state % time_levs(1) % state % layerThickness % array(k,iCell) * & - block % state % time_levs(1) % state % tracers % array(:,k,iCell) & - + rk_substep_weights(rk_step) * block % tend % tracers % array(:,k,iCell) & - ) / block % provis_state % layerThickness % array(k,iCell) - end do - - end do - - if (config_use_freq_filtered_thickness) then - - block % provis_state % lowFreqDivergence % array(:,:) = block % state % time_levs(1) % state % lowFreqDivergence % array(:,:) & - + rk_substep_weights(rk_step) * block % tend % lowFreqDivergence % array(:,:) - - end if - - if (config_prescribe_velocity) then - block % provis_state % normalVelocity % array(:,:) = block % state % time_levs(1) % state % normalVelocity % array(:,:) - end if - - if (config_prescribe_thickness) then - block % provis_state % layerThickness % array(:,:) = block % state % time_levs(1) % state % layerThickness % array(:,:) - end if - - call ocn_diagnostic_solve(dt, block % provis_state, block % forcing, block % mesh, block % diagnostics, block % scratch) - - ! Compute velocity transport, used in advection terms of layerThickness and tracer tendency - block % diagnostics % uTransport % array(:,:) & - = block % provis_state % normalVelocity % array(:,:) & - + block % diagnostics % uBolusGM % array(:,:) - - block => block % next - end do - end if - call mpas_timer_stop("RK4-update diagnostic variables") - -!--- accumulate update (for RK4) - - call mpas_timer_start("RK4-RK4 accumulate update") - block => domain % blocklist - do while (associated(block)) - block % state % time_levs(2) % state % normalVelocity % array(:,:) = block % state % time_levs(2) % state % normalVelocity % array(:,:) & - + rk_weights(rk_step) * block % tend % normalVelocity % array(:,:) - - block % state % time_levs(2) % state % layerThickness % array(:,:) = block % state % time_levs(2) % state % layerThickness % array(:,:) & - + rk_weights(rk_step) * block % tend % layerThickness % array(:,:) - - 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) - end do - end do - - if (config_use_freq_filtered_thickness) then - block % state % time_levs(2) % state % highFreqThickness % array(:,:) & - = block % state % time_levs(2) % state % highFreqThickness % array(:,:) & - + rk_weights(rk_step) * block % tend % highFreqThickness % array(:,:) - - block % state % time_levs(2) % state % lowFreqDivergence % array(:,:) & - = block % state % time_levs(2) % state % lowFreqDivergence % array(:,:) & - + rk_weights(rk_step) * block % tend % lowFreqDivergence % array(:,:) - end if - - block => block % next - end do - call mpas_timer_stop("RK4-RK4 accumulate update") - - end do - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! END RK loop - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call mpas_timer_stop("RK4-main loop") - - ! - ! A little clean up at the end: rescale tracer fields and compute diagnostics for new state - ! - call mpas_timer_start("RK4-cleaup phase") - - ! 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 % layerThickness % array(k, iCell) - end do - end do - - call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % forcing, block % mesh, block % diagnostics, block % scratch) - call ocn_sea_ice_formation(block % mesh, block % state % time_levs(2) % state % index_temperature, & - block % state % time_levs(2) % state % index_salinity, block % state % time_levs(2) % state % layerThickness % array, & - block % state % time_levs(2) % state % tracers % array, block % forcing % seaIceEnergy % array, err) - block => block % next - end do - - call mpas_timer_start("RK4-implicit vert mix") - block => domain % blocklist - do while(associated(block)) - - ! 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 density, layerThicknessEdge, and kineticEnergyCell 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. - call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % forcing, block % mesh, block % diagnostics, block % scratch) - - 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 % normalVelocity) - 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_prescribe_velocity) then - block % state % time_levs(2) % state % normalVelocity % array(:,:) = block % state % time_levs(1) % state % normalVelocity % array(:,:) - end if - - if (config_prescribe_thickness) then - block % state % time_levs(2) % state % layerThickness % array(:,:) = block % state % time_levs(1) % state % layerThickness % array(:,:) - end if - - call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % forcing, block % mesh, block % diagnostics, block % scratch) - - ! Compute velocity transport, used in advection terms of layerThickness and tracer tendency - block % diagnostics % uTransport % array(:,:) & - = block % state % time_levs(2) % state % normalVelocity % array(:,:) & - + block % diagnostics % uBolusGM % array(:,:) - - call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % normalVelocity % array, & - block % diagnostics % normalVelocityX % array, & - block % diagnostics % normalVelocityY % array, & - block % diagnostics % normalVelocityZ % array, & - block % diagnostics % normalVelocityZonal % array, & - block % diagnostics % normalVelocityMeridional % array & - ) - - call mpas_reconstruct(block % mesh, block % diagnostics % gradSSH % array, & - block % diagnostics % gradSSHX % array, & - block % diagnostics % gradSSHY % array, & - block % diagnostics % gradSSHZ % array, & - block % diagnostics % gradSSHZonal % array, & - block % diagnostics % gradSSHMeridional % array & - ) - - block % diagnostics % surfaceVelocity % array(block % diagnostics % index_zonalSurfaceVelocity, :) = & - block % diagnostics % normalVelocityZonal % array(1, :) - block % diagnostics % surfaceVelocity % array(block % diagnostics % index_meridionalSurfaceVelocity, :) = & - block % diagnostics % normalVelocityMeridional % array(1, :) - - block % diagnostics % SSHGradient % array(block % diagnostics % index_zonalSSHGradient, :) = & - block % diagnostics % gradSSHZonal % array(1, :) - block % diagnostics % SSHGradient % array(block % diagnostics % index_meridionalSSHGradient, :) = & - block % diagnostics % gradSSHMeridional % array(1, :) - - call ocn_time_average_accumulate(block % average, block % state % time_levs(2) % state, block % diagnostics) - call ocn_time_average_coupled_accumulate(block % diagnostics, block % forcing) - - block => block % next - end do - call mpas_timer_stop("RK4-cleaup phase") - - call mpas_deallocate_provis_state(domain % blocklist) - - end subroutine ocn_time_integrator_rk4!}}} - -end module ocn_time_integration_rk4 - -! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_time_integration_split.F b/src/core_ocean/mpas_ocn_time_integration_split.F deleted file mode 100644 index 1efee1f488..0000000000 --- a/src/core_ocean/mpas_ocn_time_integration_split.F +++ /dev/null @@ -1,1118 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_time_integration_split -! -!> \brief MPAS ocean split explicit time integration scheme -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date September 2011 -!> \details -!> This module contains the routine for the split explicit -!> time integration scheme -! -!----------------------------------------------------------------------- - - -module ocn_time_integration_split - - use mpas_grid_types - use mpas_configure - use mpas_constants - use mpas_dmpar - use mpas_vector_reconstruction - use mpas_spline_interpolation - use mpas_timer - - use ocn_tendency - use ocn_diagnostics - - use ocn_equation_of_state - use ocn_vmix - use ocn_time_average - use ocn_time_average_coupled - - use ocn_sea_ice - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_time_integrator_split - - type (timer_node), pointer :: timer_main, timer_prep, timer_bcl_vel, timer_btr_vel, timer_diagnostic_update, timer_implicit_vmix, & - timer_halo_diagnostic, timer_halo_normalBarotropicVelocity, timer_halo_ssh, timer_halo_f, timer_halo_thickness, & - timer_halo_tracers, timer_halo_normalBaroclinicVelocity - - contains - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_time_integration_split -! -!> \brief MPAS ocean split explicit time integration scheme -!> \author Mark Petersen, Doug Jacobsen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine integrates a single time step (dt) using a -!> split explicit time integrator. -! -!----------------------------------------------------------------------- - - subroutine ocn_time_integrator_split(domain, dt)!{{{ - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Advance model state forward in time by the specified time step using - ! Split_Explicit timestepping scheme - ! - ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:)) - ! plus mesh meta-data - ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains - ! model state advanced forward in time by dt seconds - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - implicit none - - type (domain_type), intent(inout) :: domain - real (kind=RKIND), intent(in) :: dt - - 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), stage1_tend_time, startIndex, endIndex - type (block_type), pointer :: block - real (kind=RKIND) :: normalThicknessFluxSum, thicknessSum, flux, sshEdge, hEdge1, & - CoriolisTerm, uCorr, temp, temp_h, coef, barotropicThicknessFlux_coeff, sshCell1, sshCell2 - integer :: num_tracers, ucorr_coef, err - real (kind=RKIND), dimension(:,:), pointer :: & - u, h, layerThicknessEdge, vertViscTopOfEdge, vertDiffTopOfCell - real (kind=RKIND), dimension(:,:,:), pointer :: tracers - integer, dimension(:), pointer :: & - maxLevelCell, maxLevelEdgeTop - real (kind=RKIND), dimension(:), allocatable:: uTemp - real (kind=RKIND), dimension(:,:), allocatable:: tracersTemp - - call mpas_timer_start("se timestep", .false., timer_main) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Prep variables before first iteration - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call mpas_timer_start("se prep", .false., timer_prep) - block => domain % blocklist - do while (associated(block)) - - ! Initialize * variables that are used to compute baroclinic tendencies below. - do iEdge=1,block % mesh % nEdges - do k=1,block % mesh % nVertLevels !maxLevelEdgeTop % array(iEdge) - - ! 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 normalBarotropicVelocity from the previous timestep. - ! Note that normalBaroclinicVelocity may now include a barotropic component, because the - ! weights layerThickness have changed. That is OK, because the barotropicForcing variable - ! subtracts out the barotropic component from the baroclinic. - block % state % time_levs(1) % state % normalBaroclinicVelocity % array(k,iEdge) & - = block % state % time_levs(1) % state % normalVelocity % array(k,iEdge) & - - block % state % time_levs(1) % state % normalBarotropicVelocity % array( iEdge) - - block % state % time_levs(2) % state % normalVelocity % array(k,iEdge) & - = block % state % time_levs(1) % state % normalVelocity % array(k,iEdge) - - block % state % time_levs(2) % state % normalBaroclinicVelocity % array(k,iEdge) & - = block % state % time_levs(1) % state % normalBaroclinicVelocity % array(k,iEdge) - - block % diagnostics % layerThicknessEdge % array(k,iEdge) & - = block % diagnostics % layerThicknessEdge % array(k,iEdge) - - end do - end do - - block % state % time_levs(2) % state % ssh % array(:) & - = block % state % time_levs(1) % state % ssh % array(:) - - do iCell=1,block % mesh % nCells - do k=1,block % mesh % maxLevelCell % array(iCell) - - block % state % time_levs(2) % state % layerThickness % array(k,iCell) & - = block % state % time_levs(1) % state % layerThickness % array(k,iCell) - - block % state % time_levs(2) % state % tracers % array(:,k,iCell) & - = block % state % time_levs(1) % state % tracers % array(:,k,iCell) - - end do - end do - - if (config_use_freq_filtered_thickness) then - - block % state % time_levs(2) % state % highFreqThickness % array(:,:) & - = block % state % time_levs(1) % state % highFreqThickness % array(:,:) - - block % state % time_levs(2) % state % lowFreqDivergence % array(:,:) & - = block % state % time_levs(1) % state % lowFreqDivergence % array(:,:) - - endif - - block => block % next - end do - - call mpas_timer_stop("se prep", timer_prep) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! BEGIN large iteration loop - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - n_bcl_iter = config_n_bcl_iter_mid - n_bcl_iter(1) = config_n_bcl_iter_beg - n_bcl_iter(config_n_ts_iter) = config_n_bcl_iter_end - - do split_explicit_step = 1, config_n_ts_iter - stage1_tend_time = min(split_explicit_step,2) - - ! --- update halos for diagnostic variables - call mpas_timer_start("se halo diag", .false., timer_halo_diagnostic) - call mpas_dmpar_exch_halo_field(domain % blocklist % diagnostics % normalizedRelativeVorticityEdge) - if (config_mom_del4 > 0.0) then - call mpas_dmpar_exch_halo_field(domain % blocklist % diagnostics % divergence) - call mpas_dmpar_exch_halo_field(domain % blocklist % diagnostics % relativeVorticity) - end if - call mpas_timer_stop("se halo diag", timer_halo_diagnostic) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Stage 1: Baroclinic velocity (3D) prediction, explicit with long timestep - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if (config_use_freq_filtered_thickness) then - call mpas_timer_start("se freq-filtered-thick computations") - block => domain % blocklist - do while (associated(block)) - call ocn_tend_freq_filtered_thickness(block % tend, & - block % state % time_levs(stage1_tend_time) % state, block % diagnostics, block % mesh) - block => block % next - end do - call mpas_timer_stop("se freq-filtered-thick computations") - - call mpas_timer_start("se freq-filtered-thick halo update") - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % highFreqThickness) - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % lowFreqDivergence) - call mpas_timer_stop("se freq-filtered-thick halo update") - - block => domain % blocklist - do while (associated(block)) - do iCell=1,block % mesh % nCells - do k=1,block % mesh % maxLevelCell % array(iCell) - ! this is h^{hf}_{n+1} - block % state % time_levs(2) % state % highFreqThickness % array(k,iCell) & - = block % state % time_levs(1) % state % highFreqThickness % array(k,iCell) & - + dt* block % tend % highFreqThickness % array(k,iCell) - end do - end do - block => block % next - end do - - endif - - - ! compute velocity tendencies, T(u*,w*,p*) - call mpas_timer_start("se bcl vel", .false., timer_bcl_vel) - - block => domain % blocklist - do while (associated(block)) - - ! compute vertTransportVelocityTop. Use u (rather than uTransport) for momentum advection. - ! Use the most recent time level available. - call ocn_vert_transport_velocity_top(block % mesh, block % verticalMesh, & - block % state % time_levs(1) % state % layerThickness % array, & - block % diagnostics % layerThicknessEdge % array, & - block % state % time_levs(stage1_tend_time) % state % normalVelocity % array, & - block % state % time_levs(1) % state % ssh % array, & - block % state % time_levs(2) % state % highFreqThickness % array, dt, & - block % diagnostics % vertTransportVelocityTop % array, err) - - call ocn_tend_vel(block % tend, block % state % time_levs(stage1_tend_time) % state, block % forcing, block % diagnostics, block % mesh, block % scratch) - - block => block % next - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! BEGIN baroclinic iterations on linear Coriolis term - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - 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_integrator) == 'unsplit_explicit') then - split = 0 - elseif (trim(config_time_integrator) == 'split_explicit') then - split = 1 - endif - - block => domain % blocklist - do while (associated(block)) - allocate(uTemp(block % mesh % nVertLevels)) - - ! Put f*normalBaroclinicVelocity^{perp} in uNew as a work variable - call ocn_fuperp(block % state % time_levs(2) % state , block % mesh) - - do iEdge=1,block % mesh % nEdges - cell1 = block % mesh % cellsOnEdge % array(1,iEdge) - cell2 = block % mesh % cellsOnEdge % array(2,iEdge) - - uTemp = 0.0 ! could put this after with uTemp(maxleveledgetop+1:nvertlevels)=0 - do k=1,block % mesh % maxLevelEdgeTop % array(iEdge) - - ! normalBaroclinicVelocityNew = normalBaroclinicVelocityOld + dt*(-f*normalBaroclinicVelocityPerp + T(u*,w*,p*) + g*grad(SSH*) ) - ! Here uNew is a work variable containing -fEdge(iEdge)*normalBaroclinicVelocityPerp(k,iEdge) - uTemp(k) = block % state % time_levs(1) % state % normalBaroclinicVelocity % array(k,iEdge) & - + dt * (block % tend % normalVelocity % array (k,iEdge) & - + block % state % time_levs(2) % state % normalVelocity % array (k,iEdge) & ! this is f*normalBaroclinicVelocity^{perp} - + split * gravity * ( block % state % time_levs(2) % state % ssh % array(cell2) & - - block % state % time_levs(2) % state % ssh % array(cell1) ) & - /block % mesh % dcEdge % array(iEdge) ) - enddo - - ! thicknessSum is initialized outside the loop because on land boundaries - ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a - ! nonzero value to avoid a NaN. - normalThicknessFluxSum = block % diagnostics % layerThicknessEdge % array(1,iEdge) * uTemp(1) - thicknessSum = block % diagnostics % layerThicknessEdge % array(1,iEdge) - - do k=2,block % mesh % maxLevelEdgeTop % array(iEdge) - normalThicknessFluxSum = normalThicknessFluxSum + block % diagnostics % layerThicknessEdge % array(k,iEdge) * uTemp(k) - thicknessSum = thicknessSum + block % diagnostics % layerThicknessEdge % array(k,iEdge) - enddo - block % diagnostics % barotropicForcing % array(iEdge) = split*normalThicknessFluxSum/thicknessSum/dt - - - do k=1,block % mesh % maxLevelEdgeTop % array(iEdge) - ! These two steps are together here: - !{\bf u}'_{k,n+1} = {\bf u}'_{k,n} - \Delta t {\overline {\bf G}} - !{\bf u}'_{k,n+1/2} = \frac{1}{2}\left({\bf u}^{'}_{k,n} +{\bf u}'_{k,n+1}\right) - ! so that normalBaroclinicVelocityNew is at time n+1/2 - block % state % time_levs(2) % state % normalBaroclinicVelocity % array(k,iEdge) & - = 0.5*( & - block % state % time_levs(1) % state % normalBaroclinicVelocity % array(k,iEdge) & - + uTemp(k) - dt * block % diagnostics % barotropicForcing % array(iEdge)) - - enddo - - enddo ! iEdge - - deallocate(uTemp) - - block => block % next - end do - - call mpas_timer_start("se halo normalBaroclinicVelocity", .false., timer_halo_normalBaroclinicVelocity) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(2) % state % normalBaroclinicVelocity) - call mpas_timer_stop("se halo normalBaroclinicVelocity", timer_halo_normalBaroclinicVelocity) - - end do ! do j=1,config_n_bcl_iter - - call mpas_timer_stop("se bcl vel", timer_bcl_vel) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! END baroclinic iterations on linear Coriolis term - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Stage 2: Barotropic velocity (2D) prediction, explicitly subcycled - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call mpas_timer_start("se btr vel", .false., timer_btr_vel) - - oldBtrSubcycleTime = 1 - newBtrSubcycleTime = 2 - - if (trim(config_time_integrator) == 'unsplit_explicit') then - - block => domain % blocklist - do while (associated(block)) - - ! For Split_Explicit unsplit, simply set normalBarotropicVelocityNew=0, normalBarotropicVelocitySubcycle=0, and uNew=normalBaroclinicVelocityNew - block % state % time_levs(2) % state % normalBarotropicVelocity % array(:) = 0.0 - - block % state % time_levs(2) % state % normalVelocity % array(:,:) = block % state % time_levs(2) % state % normalBaroclinicVelocity % array(:,:) - - do iEdge=1,block % mesh % nEdges - do k=1,block % mesh % nVertLevels - - ! uTranport = normalBaroclinicVelocity + uBolus - ! This is u used in advective terms for layerThickness and tracers - ! in tendency calls in stage 3. - block % diagnostics % uTransport % array(k,iEdge) & - = block % mesh % edgeMask % array(k,iEdge) & - *( block % state % time_levs(2) % state % normalBaroclinicVelocity % array(k,iEdge) & - + block % diagnostics % uBolusGM % array(k,iEdge) ) - - enddo - end do ! iEdge - - block => block % next - end do ! block - - elseif (trim(config_time_integrator) == 'split_explicit') then - - ! Initialize variables for barotropic subcycling - block => domain % blocklist - do while (associated(block)) - - if (config_filter_btr_mode) then - block % diagnostics % barotropicForcing % array(:) = 0.0 - endif - - do iCell=1,block % mesh % nCells - ! sshSubcycleOld = sshOld - block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) & - = block % state % time_levs(1) % state % ssh % array(iCell) - end do - - do iEdge=1,block % mesh % nEdges - - ! normalBarotropicVelocitySubcycleOld = normalBarotropicVelocityOld - block % state % time_levs(oldBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - = block % state % time_levs(1) % state % normalBarotropicVelocity % array(iEdge) - - ! normalBarotropicVelocityNew = BtrOld This is the first for the summation - block % state % time_levs(2) % state % normalBarotropicVelocity % array(iEdge) & - = block % state % time_levs(1) % state % normalBarotropicVelocity % array(iEdge) - - ! barotropicThicknessFlux = 0 - block % diagnostics % barotropicThicknessFlux % array(iEdge) = 0.0 - end do - - block => block % next - end do ! block - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! BEGIN Barotropic subcycle loop - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do j=1,config_n_btr_subcycles*config_btr_subcycle_loop_factor - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Barotropic subcycle: VELOCITY PREDICTOR STEP - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (config_btr_gam1_velWt1>1.0e-12) then ! only do this part if it is needed in next SSH solve - uPerpTime = oldBtrSubcycleTime - - block => domain % blocklist - do while (associated(block)) - - do iEdge=1,block % mesh % nEdges - - cell1 = block % mesh % cellsOnEdge % array(1,iEdge) - cell2 = block % mesh % cellsOnEdge % array(2,iEdge) - - ! Compute the barotropic Coriolis term, -f*uPerp - CoriolisTerm = 0.0 - 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 % normalBarotropicVelocitySubcycle % array(eoe) & - * block % mesh % fEdge % array(eoe) - end do - - ! normalBarotropicVelocityNew = normalBarotropicVelocityOld + dt/J*(-f*normalBarotropicVelocityoldPerp - g*grad(SSH) + G) - block % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - = (block % state % time_levs(oldBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - + dt / config_n_btr_subcycles * (CoriolisTerm - gravity & - * (block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) & - - block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) ) & - / block % mesh % dcEdge % array(iEdge) & - + block % diagnostics % barotropicForcing % array(iEdge))) * block % mesh % edgeMask % array(1, iEdge) - end do - - block => block % next - end do ! block - - ! boundary update on normalBarotropicVelocityNew - call mpas_timer_start("se halo normalBarotropicVelocity", .false., timer_halo_normalBarotropicVelocity) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle) - call mpas_timer_stop("se halo normalBarotropicVelocity", timer_halo_normalBarotropicVelocity) - endif ! config_btr_gam1_velWt1>1.0e-12 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Barotropic subcycle: SSH PREDICTOR STEP - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - block => domain % blocklist - do while (associated(block)) - - block % tend % ssh % array(:) = 0.0 - - if (config_btr_solve_SSH2) then - ! If config_btr_solve_SSH2=.true., then do NOT accumulate barotropicThicknessFlux in this SSH predictor - ! section, because it will be accumulated in the SSH corrector section. - barotropicThicknessFlux_coeff = 0.0 - else - ! otherwise, DO accumulate barotropicThicknessFlux in this SSH predictor section - barotropicThicknessFlux_coeff = 1.0 - endif - - ! config_btr_gam1_velWt1 sets the forward weighting of velocity in the SSH computation - ! config_btr_gam1_velWt1= 1 flux = normalBarotropicVelocityNew*H - ! config_btr_gam1_velWt1=0.5 flux = 1/2*(normalBarotropicVelocityNew+normalBarotropicVelocityOld)*H - ! config_btr_gam1_velWt1= 0 flux = normalBarotropicVelocityOld*H - - 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: - !thicknessSum = sshEdge + block % mesh % refBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1) - - ! method 1, matches method 0 without pbcs, works with pbcs. - thicknessSum = 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. - !thicknessSum = sshEdge + 0.5 *( block % mesh % bottomDepth % array(cell1) & - ! + block % mesh % bottomDepth % array(cell2) ) - - - flux = ((1.0-config_btr_gam1_velWt1) * block % state % time_levs(oldBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - + config_btr_gam1_velWt1 * block % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge)) & - * thicknessSum - - 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) ) - - ! method 0: orig, works only without pbc: - !thicknessSum = sshEdge + block % mesh % refBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1) - - ! method 1, matches method 0 without pbcs, works with pbcs. - thicknessSum = 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 - !thicknessSum = sshEdge + 0.5 *( block % mesh % bottomDepth % array(cell1) & - ! + block % mesh % bottomDepth % array(cell2) ) - - flux = ((1.0-config_btr_gam1_velWt1) * block % state % time_levs(oldBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - + config_btr_gam1_velWt1 * block % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge)) & - * thicknessSum - - block % diagnostics % barotropicThicknessFlux % array(iEdge) = block % diagnostics % barotropicThicknessFlux % array(iEdge) & - + barotropicThicknessFlux_coeff*flux - end do - - ! SSHnew = SSHold + dt/J*(-div(Flux)) - do iCell=1,block % mesh % nCells - - block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(iCell) & - = block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) & - + dt/config_n_btr_subcycles * block % tend % ssh % array(iCell) / block % mesh % areaCell % array (iCell) - - end do - - block => block % next - end do ! block - - ! boundary update on SSHnew - call mpas_timer_start("se halo ssh", .false., timer_halo_ssh) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle) - call mpas_timer_stop("se halo ssh", timer_halo_ssh) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Barotropic subcycle: VELOCITY CORRECTOR STEP - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do BtrCorIter=1,config_n_btr_cor_iter - uPerpTime = newBtrSubcycleTime - - block => domain % blocklist - do while (associated(block)) - allocate(utemp(block % mesh % nEdges+1)) - uTemp(:) = block % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(:) - do iEdge=1,block % mesh % nEdges - cell1 = block % mesh % cellsOnEdge % array(1,iEdge) - cell2 = block % mesh % cellsOnEdge % array(2,iEdge) - - ! Compute the barotropic Coriolis term, -f*uPerp - CoriolisTerm = 0.0 - 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 % normalBarotropicVelocitySubcycle % array(eoe) & - * uTemp(eoe) & - * block % mesh % fEdge % array(eoe) - end do - - ! In this final solve for velocity, 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) - - ! normalBarotropicVelocityNew = normalBarotropicVelocityOld + dt/J*(-f*normalBarotropicVelocityoldPerp - g*grad(SSH) + G) - block % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - = (block % state % time_levs(oldBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - + dt/config_n_btr_subcycles *(CoriolisTerm - gravity *(sshCell2 - sshCell1) /block % mesh % dcEdge % array(iEdge) & - + block % diagnostics % barotropicForcing % array(iEdge))) * block % mesh % edgeMask % array(1,iEdge) - end do - deallocate(uTemp) - - block => block % next - end do ! block - - ! boundary update on normalBarotropicVelocityNew - call mpas_timer_start("se halo normalBarotropicVelocity", .false., timer_halo_normalBarotropicVelocity) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle) - call mpas_timer_stop("se halo normalBarotropicVelocity", timer_halo_normalBarotropicVelocity) - end do !do BtrCorIter=1,config_n_btr_cor_iter - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Barotropic subcycle: SSH CORRECTOR STEP - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (config_btr_solve_SSH2) then - - block => domain % blocklist - do while (associated(block)) - block % tend % ssh % array(:) = 0.0 - - ! config_btr_gam3_velWt2 sets the forward weighting of velocity in the SSH computation - ! config_btr_gam3_velWt2= 1 flux = normalBarotropicVelocityNew*H - ! config_btr_gam3_velWt2=0.5 flux = 1/2*(normalBarotropicVelocityNew+normalBarotropicVelocityOld)*H - ! config_btr_gam3_velWt2= 0 flux = normalBarotropicVelocityOld*H - - 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: - !thicknessSum = sshEdge + block % mesh % refBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1) - - ! method 1, matches method 0 without pbcs, works with pbcs. - thicknessSum = 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 - !thicknessSum = sshEdge + 0.5 *( block % mesh % bottomDepth % array(cell1) & - ! + block % mesh % bottomDepth % array(cell2) ) - - - flux = ((1.0-config_btr_gam3_velWt2) * block % state % time_levs(oldBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - + config_btr_gam3_velWt2 * block % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge)) & - * thicknessSum - - 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) - - ! 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: - !thicknessSum = sshEdge + block % mesh % refBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1) - - ! method 1, matches method 0 without pbcs, works with pbcs. - thicknessSum = 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 - !thicknessSum = sshEdge + 0.5 *( block % mesh % bottomDepth % array(cell1) & - ! + block % mesh % bottomDepth % array(cell2) ) - - flux = ((1.0-config_btr_gam3_velWt2) * block % state % time_levs(oldBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) & - + config_btr_gam3_velWt2 * block % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge)) & - * thicknessSum - - block % diagnostics % barotropicThicknessFlux % array(iEdge) = block % diagnostics % barotropicThicknessFlux % array(iEdge) + flux - end do - - ! SSHnew = SSHold + dt/J*(-div(Flux)) - do iCell=1,block % mesh % nCells - block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(iCell) & - = block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) & - + dt/config_n_btr_subcycles * block % tend % ssh % array(iCell) / block % mesh % areaCell % array (iCell) - end do - - block => block % next - end do ! block - - ! boundary update on SSHnew - call mpas_timer_start("se halo ssh", .false., timer_halo_ssh) - call mpas_dmpar_exch_halo_field(domain % blocklist % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle) - call mpas_timer_stop("se halo ssh", timer_halo_ssh) - endif ! config_btr_solve_SSH2 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Barotropic subcycle: Accumulate running sums, advance timestep pointers - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - block => domain % blocklist - do while (associated(block)) - - ! normalBarotropicVelocityNew = normalBarotropicVelocityNew + normalBarotropicVelocitySubcycleNEW - ! This accumulates the sum. - ! If the Barotropic Coriolis iteration is limited to one, this could - ! be merged with the above code. - do iEdge=1,block % mesh % nEdges - - block % state % time_levs(2) % state % normalBarotropicVelocity % array(iEdge) & - = block % state % time_levs(2) % state % normalBarotropicVelocity % array(iEdge) & - + block % state % time_levs(newBtrSubcycleTime) % state % normalBarotropicVelocitySubcycle % array(iEdge) - - end do ! iEdge - block => block % next - end do ! block - - ! advance time pointers - oldBtrSubcycleTime = mod(oldBtrSubcycleTime,2)+1 - newBtrSubcycleTime = mod(newBtrSubcycleTime,2)+1 - - end do ! j=1,config_n_btr_subcycles - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! END Barotropic subcycle loop - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! Normalize Barotropic subcycle sums: ssh, normalBarotropicVelocity, and F - block => domain % blocklist - do while (associated(block)) - - do iEdge=1,block % mesh % nEdges - block % diagnostics % barotropicThicknessFlux % array(iEdge) = block % diagnostics % barotropicThicknessFlux % array(iEdge) & - / (config_n_btr_subcycles*config_btr_subcycle_loop_factor) - - block % state % time_levs(2) % state % normalBarotropicVelocity % array(iEdge) = block % state % time_levs(2) % state % normalBarotropicVelocity % array(iEdge) & - / (config_n_btr_subcycles*config_btr_subcycle_loop_factor + 1) - end do - - block => block % next - end do ! block - - - ! boundary update on F - call mpas_timer_start("se halo F", .false., timer_halo_f) - call mpas_dmpar_exch_halo_field(domain % blocklist % diagnostics % barotropicThicknessFlux) - call mpas_timer_stop("se halo F", timer_halo_f) - - - ! Check that you can compute SSH using the total sum or the individual increments - ! over the barotropic subcycles. - ! efficiency: This next block of code is really a check for debugging, and can - ! be removed later. - block => domain % blocklist - do while (associated(block)) - - allocate(uTemp(block % mesh % nVertLevels)) - - ! Correction velocity uCorr = (Flux - Sum(h u*))/H - ! or, for the full latex version: - !{\bf u}^{corr} = \left( {\overline {\bf F}} - ! - \sum_{k=1}^{N^{edge}} h_{k,*}^{edge} {\bf u}_k^{avg} \right) - ! \left/ \sum_{k=1}^{N^{edge}} h_{k,*}^{edge} \right. - - if (config_vel_correction) then - ucorr_coef = 1 - else - ucorr_coef = 0 - endif - - do iEdge=1,block % mesh % nEdges - - ! velocity for uCorrection is normalBarotropicVelocity + normalBaroclinicVelocity + uBolus - uTemp(:) & - = block % state % time_levs(2) % state % normalBarotropicVelocity % array( iEdge) & - + block % state % time_levs(2) % state % normalBaroclinicVelocity % array(:,iEdge) & - + block % diagnostics % uBolusGM % array(:,iEdge) - - ! thicknessSum is initialized outside the loop because on land boundaries - ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a - ! nonzero value to avoid a NaN. - normalThicknessFluxSum = block % diagnostics % layerThicknessEdge % array(1,iEdge) * uTemp(1) - thicknessSum = block % diagnostics % layerThicknessEdge % array(1,iEdge) - - do k=2,block % mesh % maxLevelEdgeTop % array(iEdge) - normalThicknessFluxSum = normalThicknessFluxSum + block % diagnostics % layerThicknessEdge % array(k,iEdge) * uTemp(k) - thicknessSum = thicknessSum + block % diagnostics % layerThicknessEdge % array(k,iEdge) - enddo - - uCorr = ucorr_coef*(( block % diagnostics % barotropicThicknessFlux % array(iEdge) - normalThicknessFluxSum)/thicknessSum) - - do k=1,block % mesh % nVertLevels - - ! uTranport = normalBarotropicVelocity + normalBaroclinicVelocity + uBolus + uCorrection - ! This is u used in advective terms for layerThickness and tracers - ! in tendency calls in stage 3. - block % diagnostics % uTransport % array(k,iEdge) & - = block % mesh % edgeMask % array(k,iEdge) & - *( block % state % time_levs(2) % state % normalBarotropicVelocity % array( iEdge) & - + block % state % time_levs(2) % state % normalBaroclinicVelocity % array(k,iEdge) & - + block % diagnostics % uBolusGM % array(k,iEdge) & - + uCorr ) - - enddo - - end do ! iEdge - - deallocate(uTemp) - - block => block % next - end do ! block - - endif ! split_explicit - - call mpas_timer_stop("se btr vel", timer_btr_vel) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Stage 3: Tracer, density, pressure, vertical velocity prediction - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! Thickness tendency computations and thickness halo updates are completed before tracer - ! tendency computations to allow monotonic advection. - block => domain % blocklist - do while (associated(block)) - - ! compute vertTransportVelocityTop. Use uTransport for advection of layerThickness and tracers. - ! Use time level 1 values of layerThickness and layerThicknessEdge because - ! layerThickness has not yet been computed for time level 2. - call ocn_vert_transport_velocity_top(block % mesh, block % verticalMesh, & - block % state % time_levs(1) % state % layerThickness % array, & - block % diagnostics % layerThicknessEdge % array, & - block % diagnostics % uTransport % array, & - block % state % time_levs(1) % state % ssh % array, & - block % state % time_levs(2) % state % highFreqThickness % array, dt, & - block % diagnostics % vertTransportVelocityTop % array, err) - - call ocn_tend_thick(block % tend, block % state % time_levs(2) % state, block % forcing, block % diagnostics, block % mesh) - - block => block % next - end do - - ! update halo for thickness tendencies - call mpas_timer_start("se halo thickness", .false., timer_halo_thickness) - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % layerThickness) - call mpas_timer_stop("se halo thickness", timer_halo_thickness) - - block => domain % blocklist - do while (associated(block)) - call ocn_tend_tracer(block % tend, block % state % time_levs(2) % state, block % forcing, block % diagnostics, block % mesh, dt) - - block => block % next - end do - - ! update halo for tracer tendencies - call mpas_timer_start("se halo tracers", .false., timer_halo_tracers) - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % tracers) - call mpas_timer_stop("se halo tracers", timer_halo_tracers) - - block => domain % blocklist - do while (associated(block)) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! If iterating, reset variables for next iteration - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (split_explicit_step < config_n_ts_iter) then - - ! Get indices for dynamic tracers (Includes T&S). - startIndex = block % state % time_levs(1) % state % dynamics_start - endIndex = block % state % time_levs(1) % state % dynamics_end - - ! Only need T & S for earlier iterations, - ! then all the tracers needed the last time through. - do iCell=1,block % mesh % nCells - ! sshNew is a pointer, defined above. - do k=1,block % mesh % maxLevelCell % array(iCell) - - ! this is h_{n+1} - temp_h & - = block % state % time_levs(1) % state % layerThickness % array(k,iCell) & - + dt* block % tend % layerThickness % array(k,iCell) - - ! this is h_{n+1/2} - block % state % time_levs(2) % state % layerThickness % array(k,iCell) & - = 0.5*( & - block % state % time_levs(1) % state % layerThickness % array(k,iCell) & - + temp_h) - - do i=startIndex, endIndex - ! This is Phi at n+1 - temp = ( & - block % state % time_levs(1) % state % tracers % array(i,k,iCell) & - * block % state % time_levs(1) % state % layerThickness % array(k,iCell) & - + dt * block % tend % tracers % array(i,k,iCell)) & - / temp_h - - ! This is Phi at n+1/2 - block % state % time_levs(2) % state % tracers % array(i,k,iCell) & - = 0.5*( & - block % state % time_levs(1) % state % tracers % array(i,k,iCell) & - + temp ) - end do - end do - end do ! iCell - - if (config_use_freq_filtered_thickness) then - do iCell=1,block % mesh % nCells - do k=1,block % mesh % maxLevelCell % array(iCell) - - ! h^{hf}_{n+1} was computed in Stage 1 - - ! this is h^{hf}_{n+1/2} - block % state % time_levs(2) % state % highFreqThickness % array(k,iCell) & - = 0.5*(block % state % time_levs(1) % state % highFreqThickness % array(k,iCell) & - + block % state % time_levs(2) % state % highFreqThickness % array(k,iCell)) - - ! this is D^{lf}_{n+1} - temp = block % state % time_levs(1) % state % lowFreqDivergence % array(k,iCell) & - + dt* block % tend % lowFreqDivergence % array(k,iCell) - - ! this is D^{lf}_{n+1/2} - block % state % time_levs(2) % state % lowFreqDivergence % array(k,iCell) & - = 0.5*(block % state % time_levs(1) % state % lowFreqDivergence % array(k,iCell) + temp) - - end do - end do - end if - - do iEdge=1,block % mesh % nEdges - - do k=1,block % mesh % nVertLevels - - ! u = normalBarotropicVelocity + normalBaroclinicVelocity - ! here normalBaroclinicVelocity is at time n+1/2 - ! This is u used in next iteration or step - block % state % time_levs(2) % state % normalVelocity % array(k,iEdge) & - = block % mesh % edgeMask % array(k,iEdge) & - *( block % state % time_levs(2) % state % normalBarotropicVelocity % array( iEdge) & - + block % state % time_levs(2) % state % normalBaroclinicVelocity % array(k,iEdge) ) - - enddo - - end do ! iEdge - - ! Efficiency note: We really only need this to compute layerThicknessEdge, density, pressure, and SSH - ! in this diagnostics solve. - call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % forcing, block % mesh, block % diagnostics, block % scratch) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! If large iteration complete, compute all variables at time n+1 - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - elseif (split_explicit_step == config_n_ts_iter) then - - do iCell=1,block % mesh % nCells - do k=1,block % mesh % maxLevelCell % array(iCell) - - ! this is h_{n+1} - block % state % time_levs(2) % state % layerThickness % array(k,iCell) & - = block % state % time_levs(1) % state % layerThickness % array(k,iCell) & - + dt* block % tend % layerThickness % array(k,iCell) - - ! This is Phi at n+1 - do i=1,block % state % time_levs(1) % state % num_tracers - block % state % time_levs(2) % state % tracers % array(i,k,iCell) & - = (block % state % time_levs(1) % state % tracers % array(i,k,iCell) & - * block % state % time_levs(1) % state % layerThickness % array(k,iCell) & - + dt * block % tend % tracers % array(i,k,iCell)) & - / block % state % time_levs(2) % state % layerThickness % array(k,iCell) - - enddo - end do - end do - - if (config_use_freq_filtered_thickness) then - do iCell=1,block % mesh % nCells - do k=1,block % mesh % maxLevelCell % array(iCell) - - ! h^{hf}_{n+1} was computed in Stage 1 - - ! this is D^{lf}_{n+1} - block % state % time_levs(2) % state % lowFreqDivergence % array(k,iCell) & - = block % state % time_levs(1) % state % lowFreqDivergence % array(k,iCell) & - + dt* block % tend % lowFreqDivergence % array(k,iCell) - - end do - end do - end if - - ! Recompute final u to go on to next step. - ! u_{n+1} = normalBarotropicVelocity_{n+1} + normalBaroclinicVelocity_{n+1} - ! Right now normalBaroclinicVelocityNew is at time n+1/2, so back compute to get normalBaroclinicVelocity at time n+1 - ! using normalBaroclinicVelocity_{n+1/2} = 1/2*(normalBaroclinicVelocity_n + u_Bcl_{n+1}) - ! so the following lines are - ! u_{n+1} = normalBarotropicVelocity_{n+1} + 2*normalBaroclinicVelocity_{n+1/2} - normalBaroclinicVelocity_n - ! note that normalBaroclinicVelocity is recomputed at the beginning of the next timestep due to Imp Vert mixing, - ! so normalBaroclinicVelocity does not have to be recomputed here. - - do iEdge=1,block % mesh % nEdges - do k=1,block % mesh % maxLevelEdgeTop % array(iEdge) - block % state % time_levs(2) % state % normalVelocity % array(k,iEdge) & - = block % state % time_levs(2) % state % normalBarotropicVelocity % array( iEdge) & - +2*block % state % time_levs(2) % state % normalBaroclinicVelocity % array(k,iEdge) & - - block % state % time_levs(1) % state % normalBaroclinicVelocity % array(k,iEdge) - end do - end do ! iEdges - - endif ! split_explicit_step - - block => block % next - end do - - - - end do ! split_explicit_step = 1, config_n_ts_iter - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! END large iteration loop - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! Perform Sea Ice Formation Adjustment - block => domain % blocklist - do while(associated(block)) - call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % forcing, block % mesh, block % diagnostics, block % scratch) - call ocn_sea_ice_formation(block % mesh, block % state % time_levs(2) % state % index_temperature, & - block % state % time_levs(2) % state % index_salinity, block % state % time_levs(2) % state % layerThickness % array, & - block % state % time_levs(2) % state % tracers % array, block % forcing % seaIceEnergy % array, err) - block => block % next - end do - - call mpas_timer_start("se implicit vert mix") - block => domain % blocklist - do while(associated(block)) - - ! 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 density, layerThicknessEdge, and kineticEnergyCell 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. - call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % forcing, block % mesh, block % diagnostics, block % scratch) - - 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 % normalVelocity) - 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_prescribe_velocity) then - block % state % time_levs(2) % state % normalVelocity % array(:,:) = block % state % time_levs(1) % state % normalVelocity % array(:,:) - end if - - if (config_prescribe_thickness) then - block % state % time_levs(2) % state % layerThickness % array(:,:) = block % state % time_levs(1) % state % layerThickness % array(:,:) - end if - - call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % forcing, block % mesh, block % diagnostics, block % scratch) - - ! Compute velocity transport, used in advection terms of layerThickness and tracer tendency - block % diagnostics % uTransport % array(:,:) & - = block % state % time_levs(2) % state % normalVelocity % array(:,:) & - + block % diagnostics % uBolusGM % array(:,:) - - call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % normalVelocity % array, & - block % diagnostics % normalVelocityX % array, & - block % diagnostics % normalVelocityY % array, & - block % diagnostics % normalVelocityZ % array, & - block % diagnostics % normalVelocityZonal % array, & - block % diagnostics % normalVelocityMeridional % array & - ) - - call mpas_reconstruct(block % mesh, block % diagnostics % gradSSH % array, & - block % diagnostics % gradSSHX % array, & - block % diagnostics % gradSSHY % array, & - block % diagnostics % gradSSHZ % array, & - block % diagnostics % gradSSHZonal % array, & - block % diagnostics % gradSSHMeridional % array & - ) - - block % diagnostics % surfaceVelocity % array(block % diagnostics % index_zonalSurfaceVelocity, :) = & - block % diagnostics % normalVelocityZonal % array(1, :) - block % diagnostics % surfaceVelocity % array(block % diagnostics % index_meridionalSurfaceVelocity, :) = & - block % diagnostics % normalVelocityMeridional % array(1, :) - - block % diagnostics % SSHGradient % array(block % diagnostics % index_zonalSSHGradient, :) = & - block % diagnostics % gradSSHZonal % array(1, :) - block % diagnostics % SSHGradient % array(block % diagnostics % index_meridionalSSHGradient, :) = & - block % diagnostics % gradSSHMeridional % array(1, :) - - call ocn_time_average_accumulate(block % average, block % state % time_levs(2) % state, block % diagnostics) - call ocn_time_average_coupled_accumulate(block % diagnostics, block % forcing) - - block => block % next - end do - - call mpas_timer_stop("se timestep", timer_main) - - end subroutine ocn_time_integrator_split!}}} - -end module ocn_time_integration_split - -! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_tracer_hmix_del2.F b/src/core_ocean/mpas_ocn_tracer_hmix_del2.F deleted file mode 100644 index 5d702d344e..0000000000 --- a/src/core_ocean/mpas_ocn_tracer_hmix_del2.F +++ /dev/null @@ -1,218 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_tracer_hmix_del2 -! -!> \brief MPAS ocean horizontal tracer mixing driver -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This module contains the main driver routine for computing -!> horizontal mixing tendencies. -!> -!> It provides an init and a tend function. Each are described below. -! -!----------------------------------------------------------------------- - -module ocn_tracer_hmix_del2 - - use mpas_grid_types - use mpas_configure - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_tracer_hmix_del2_tend, & - ocn_tracer_hmix_del2_init - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - logical :: del2On - - real (kind=RKIND) :: eddyDiff2 - - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_tracer_hmix_del2_tend -! -!> \brief Computes Laplacian tendency term for horizontal tracer mixing -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine computes the horizontal mixing tendency for tracers -!> based on current state using a Laplacian parameterization. -! -!----------------------------------------------------------------------- - - subroutine ocn_tracer_hmix_del2_tend(mesh, layerThicknessEdge, tracers, tend, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - real (kind=RKIND), dimension(:,:), intent(in) :: & - layerThicknessEdge !< Input: thickness at edge - - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information - - real (kind=RKIND), dimension(:,:,:), intent(in) :: & - tracers !< Input: tracer quantities - - !----------------------------------------------------------------- - ! - ! 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 :: iCell, iEdge, nCells, nVertLevels, cell1, cell2 - integer :: i, k, iTracer, num_tracers - - integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnCell - integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask, edgesOnCell, edgeSignOnCell - - real (kind=RKIND) :: invAreaCell, tracer_turb_flux, flux, r_tmp - - real (kind=RKIND), dimension(:), pointer :: areaCell, dvEdge, dcEdge, meshScalingDel2 - - err = 0 - - if (.not.del2On) return - - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels - num_tracers = size(tracers, dim=1) - - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - cellsOnEdge => mesh % cellsOnEdge % array - edgeMask => mesh % edgeMask % array - areaCell => mesh % areaCell % array - dvEdge => mesh % dvEdge % array - dcEdge => mesh % dcEdge % array - meshScalingDel2 => mesh % meshScalingDel2 % array - - nEdgesOnCell => mesh % nEdgesOnCell % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnCell => mesh % edgeSignOnCell % array - - do iCell = 1, nCells - invAreaCell = 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 - ! \kappa_2 \nabla \phi on edge - tracer_turb_flux = tracers(iTracer, k, cell2) - tracers(iTracer, k, cell1) - - ! div(h \kappa_2 \nabla \phi) at cell center - flux = layerThicknessEdge(k, iEdge) * tracer_turb_flux * edgeMask(k, iEdge) * r_tmp - - tend(iTracer, k, iCell) = tend(iTracer, k, iCell) - edgeSignOnCell(i, iCell) * flux * invAreaCell - end do - end do - - end do - end do - - !-------------------------------------------------------------------- - - end subroutine ocn_tracer_hmix_del2_tend!}}} - -!*********************************************************************** -! -! routine ocn_tracer_hmix_del2_init -! -!> \brief Initializes ocean tracer horizontal mixing quantities -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine initializes a variety of quantities related to -!> Laplacian horizontal velocity mixing in the ocean. -! -!----------------------------------------------------------------------- - - subroutine ocn_tracer_hmix_del2_init(err)!{{{ - - !-------------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! call individual init routines for each parameterization - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - err = 0 - - del2on = .false. - - if ( config_tracer_del2 > 0.0 ) then - del2On = .true. - eddyDiff2 = config_tracer_del2 - endif - - if(.not.config_use_tracer_del2) del2on = .false. - - !-------------------------------------------------------------------- - - end subroutine ocn_tracer_hmix_del2_init!}}} - -!*********************************************************************** - -end module ocn_tracer_hmix_del2 - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_vel_pressure_grad.F b/src/core_ocean/mpas_ocn_vel_pressure_grad.F deleted file mode 100644 index 3236f2d850..0000000000 --- a/src/core_ocean/mpas_ocn_vel_pressure_grad.F +++ /dev/null @@ -1,218 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_vel_pressure_grad -! -!> \brief MPAS ocean pressure gradient module -!> \author Mark Petersen -!> \date September 2011 -!> \details -!> This module contains the routine for computing -!> tendencie from the horizontal pressure gradient. -!> -! -!----------------------------------------------------------------------- - -module ocn_vel_pressure_grad - - use mpas_grid_types - use mpas_configure - use mpas_constants - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_vel_pressure_grad_tend, & - ocn_vel_pressure_grad_init - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - logical :: pgradOn - real (kind=RKIND) :: density0Inv, gdensity0Inv - - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_vel_pressure_grad_tend -! -!> \brief Computes tendency term for horizontal pressure gradient -!> \author Mark Petersen -!> \date September 2011 -!> \details -!> This routine computes the pressure gradient tendency for momentum -!> based on current state. -! -!----------------------------------------------------------------------- - - subroutine ocn_vel_pressure_grad_tend(mesh, pressure, zMid, density, tend, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - real (kind=RKIND), dimension(:,:), intent(in) :: & - pressure, & !< Input: Pressure field or Mongomery potential - zMid, & !< Input: z-coordinate at mid-depth of layer - density !< Input: density - - type (mesh_type), intent(in) :: & - mesh !< Input: mesh 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 :: nEdgesSolve, iEdge, k, cell1, cell2 - integer, dimension(:), pointer :: maxLevelEdgeTop - integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask - - real (kind=RKIND), dimension(:), pointer :: dcEdge - real (kind=RKIND) :: invdcEdge - - err = 0 - - if(.not.pgradOn) return - - nEdgesSolve = mesh % nEdgesSolve - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - cellsOnEdge => mesh % cellsOnEdge % array - dcEdge => mesh % dcEdge % array - edgeMask => mesh % edgeMask % array - - ! pressure for generalized coordinates - ! -1/density_0 (grad p_k + density g grad z_k^{mid}) - - ! For pure isopycnal coordinates, we are still using - ! grad(M), the gradient of Montgomery Potential, because - ! we have set density0Inv=1 and gdensity0Inv=0 in the init routine, - ! and pressure is passed in as montgomeryPotential. - - do iEdge=1,nEdgesSolve - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - invdcEdge = 1.0 / dcEdge(iEdge) - - do k=1,maxLevelEdgeTop(iEdge) - tend(k,iEdge) = tend(k,iEdge) & - - edgeMask(k,iEdge) * density0Inv*( pressure(k,cell2) & - - pressure(k,cell1) )* invdcEdge & - - edgeMask(k,iEdge) * gdensity0Inv* 0.5*(density(k,cell1)+density(k,cell2)) & - *( zMid(k,cell2) & - - zMid(k,cell1) )* invdcEdge - - end do - - end do - - - - !-------------------------------------------------------------------- - - end subroutine ocn_vel_pressure_grad_tend!}}} - -!*********************************************************************** -! -! routine ocn_vel_pressure_grad_init -! -!> \brief Initializes ocean momentum horizontal pressure gradient -!> \author Mark Petersen -!> \date September 2011 -!> \details -!> This routine initializes parameters required for the computation of the -!> horizontal pressure gradient. -! -!----------------------------------------------------------------------- - - subroutine ocn_vel_pressure_grad_init(err)!{{{ - - !-------------------------------------------------------------------- - - - !----------------------------------------------------------------- - ! - ! Output Variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - - !----------------------------------------------------------------- - ! - ! call individual init routines for each parameterization - ! - !----------------------------------------------------------------- - - err = 0 - - pgradOn = .true. - - if (config_pressure_gradient_type.eq.'MontgomeryPotential') then - density0Inv = 1.0 - gdensity0Inv = 0.0 - else - density0Inv = 1.0/config_density0 - gdensity0Inv = gravity/config_density0 - end if - - if(config_disable_vel_pgrad) pgradOn = .false. - - - - !-------------------------------------------------------------------- - - end subroutine ocn_vel_pressure_grad_init!}}} - -!*********************************************************************** - -end module ocn_vel_pressure_grad - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/src/core_ocean/mpas_ocn_vmix_cvmix.F b/src/core_ocean/mpas_ocn_vmix_cvmix.F deleted file mode 100644 index 1ab253d850..0000000000 --- a/src/core_ocean/mpas_ocn_vmix_cvmix.F +++ /dev/null @@ -1,420 +0,0 @@ -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_vmix_cvmix -! -!> \brief MPAS ocean vertical mixing interface to CVMix -!> \author Todd Ringler -!> \date 04 February 2013 -!> \version SVN:$Id:$ -!> \details -!> This module contains the routines for calls into CVMix -!> -! -!----------------------------------------------------------------------- - -module ocn_vmix_cvmix - - use mpas_grid_types - use mpas_configure - use mpas_timer - use mpas_io_units - - use cvmix_kinds_and_types - use cvmix_put_get - use cvmix_background - use cvmix_ddiff - use cvmix_convection - use cvmix_shear - use cvmix_tidal - use cvmix_kpp - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_vmix_coefs_cvmix_build, & - ocn_vmix_cvmix_init - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - type(cvmix_global_params_type) :: cvmix_global_params - type(cvmix_bkgnd_params_type) :: cvmix_background_params - type(cvmix_conv_params_type) :: cvmix_conv_params - type(cvmix_kpp_params_type) :: cvmix_kpp_params - type(cvmix_data_type) :: cvmix_variables - - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_vmix_coefs_cmvix_build -! -!> \brief Computes mixing coefficients using CVMix -!> \author Todd Ringler -!> \date 04 February 2013 -!> \version SVN:$Id$ -!> \details -!> This routine computes the vertical mixing coefficients for momentum -!> and tracers by calling CVMix routines. -! -!----------------------------------------------------------------------- - - subroutine ocn_vmix_coefs_cvmix_build(mesh, state, diagnostics, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - - type (state_type), intent(inout) :: & - state !< Input/Output: state information - - type (diagnostics_type), intent(inout) :: & - diagnostics !< Input/Output: diagnostic information - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - integer, dimension(:), pointer :: & - maxLevelCell - - real (kind=RKIND), dimension(:), pointer :: & - latCell, lonCell, bottomDepth, buoyancyForcingOBL, surfaceFrictionVelocity, fCell - - real (kind=RKIND), dimension(:,:), pointer :: & - vertViscTopOfCell, vertDiffTopOfCell, layerThickness, & - bulkRichardsonNumber, zMid, zTop, density, displacedDensity, potentialDensity - - integer :: iCell, nVertLevels - - !----------------------------------------------------------------- - ! - ! call relevant routines for computing mixing-related fields - ! note that the user can choose multiple options and the - ! mixing fields have to be merged together - ! - !----------------------------------------------------------------- - - ! - ! assume no errors during initialization and set to 1 when error is encountered - ! - err=0 - -! write(stdoutUnit,*) 'TDR: ocn_vmix_coefs_cvmix_build enter' - - ! - ! only build up viscosity/diffusivity if CVMix is turned on - ! - if(.not.config_use_cvmix) return - - ! - ! set parameters - ! - nVertLevels = mesh % nVertLevels - - ! - ! set pointers for fields related to position on sphere - ! - latCell => mesh % latCell % array(:) - lonCell => mesh % lonCell % array(:) - fCell => mesh % fCell % array(:) - - ! - ! set pointers for fields related to vertical mesh - ! - maxLevelCell => mesh % maxLevelCell % array(:) - bottomDepth => mesh % bottomDepth % array(:) - layerThickness => state % layerThickness % array(:,:) - zTop => diagnostics % zTop % array(:,:) - zMid => diagnostics % zMid % array(:,:) - - ! - ! set pointers for fields related ocean state - ! - density => diagnostics % density % array(:,:) - displacedDensity => diagnostics % displacedDensity % array(:,:) - potentialDensity => diagnostics % potentialDensity % array(:,:) - bulkRichardsonNumber => diagnostics % bulkRichardsonNumber % array(:,:) - - ! - ! set pointers for fields related ocean forcing at surface - ! - surfaceFrictionVelocity => diagnostics % surfaceFrictionVelocity % array(:) - buoyancyForcingOBL => diagnostics % buoyancyForcingOBL % array(:) - - ! - ! set pointers for viscosity/diffusivity and intialize to zero - ! - vertViscTopOfCell => diagnostics % vertViscTopOfCell % array(:,:) - vertDiffTopOfCell => diagnostics % vertDiffTopOfCell % array(:,:) - - vertViscTopOfCell = 0.0 - vertDiffTopOfCell = 0.0 - - ! - ! start by setting visocity/diffusivity to there mininum background values - ! - if (config_use_cvmix_background) then - vertViscTopOfCell(:,:) = vertViscTopOfCell(:,:) + config_cvmix_background_viscosity - vertDiffTopOfCell(:,:) = vertDiffTopOfCell(:,:) + config_cvmix_background_diffusion -! write(stdoutUnit,*) 'TDR: config_use_cvmix_background',config_use_cvmix_background,maxval(vertViscTopOfCell(:,:)) - endif - - ! - ! allocate selected cvmix variables and loop over columns - ! - allocate(cvmix_variables % visc_iface(nVertLevels+1)) - allocate(cvmix_variables % diff_iface(nVertLevels+1,2)) - allocate(cvmix_variables % zw_iface(nVertLevels+1)) - - do iCell=1,mesh%nCellsSolve - - ! zero the cvmix viscosity/diffusivity - cvmix_variables % visc_iface(:)=0.0 - cvmix_variables % diff_iface(:,:)=0.0 - - ! fill the intent(in) convective adjustment - cvmix_variables % nlev = mesh % maxLevelCell % array(iCell) - cvmix_variables % ocn_depth = mesh % bottomDepth % array(iCell) - cvmix_variables % dens => diagnostics % displacedDensity % array(:,iCell) - cvmix_variables % dens_lwr => diagnostics % density % array(:,iCell) - - ! call convective mixing scheme - ! (NOTE: cvmix_coeffs_conv might be incorrect) - if (config_use_cvmix_convection) then - call cvmix_coeffs_conv(cvmix_variables) - - ! add convective mixing to vertical viscosity/diffusivity - vertViscTopOfCell(:,iCell) = vertViscTopOfCell(:,iCell) + cvmix_variables % visc_iface(:) - vertDiffTopOfCell(:,iCell) = vertDiffTopOfCell(:,iCell) + cvmix_variables % diff_iface(:,1) - - endif - - ! call kpp ocean mixed layer scheme - if (config_use_cvmix_kpp) then - -! write(stdoutUnit,*) 'TDR: config_use_cvmix_kpp enter',config_use_cvmix_kpp - - ! set cvmix viscosity/diffusity to current total values to be used for matching - cvmix_variables % visc_iface(1:nVertLevels)=vertViscTopOfCell(1:nVertLevels,iCell) - cvmix_variables % diff_iface(1:nVertLevels,1)=vertDiffTopofCell(1:nVertLevels,iCell) - cvmix_variables % diff_iface(1:nVertLevels,2)=vertDiffTopofCell(1:nVertLevels,iCell) - - ! set matching visc/diff to zero at upper (1) and lower (nVertlevels+1) boundaries - cvmix_variables % visc_iface(1) = 0.0 - cvmix_variables % visc_iface(nVertLevels+1) = 0.0 - cvmix_variables % diff_iface(1,:) = 0.0 - cvmix_variables % diff_iface(nVertLevels+1,:) = 0.0 - -! write(stdoutUnit,*) 'TDR: cvmix_variables % visc_iface',maxval(cvmix_variables % visc_iface) -! write(stdoutUnit,*) 'TDR: cvmix_variables % diff_iface',maxval(cvmix_variables % diff_iface) - - ! set integer and real - cvmix_variables % surf_hgt = state % ssh % array(iCell) - cvmix_variables % Coriolis = mesh % fCell % array(iCell) - cvmix_variables % lat = mesh % latCell % array(iCell) * 180.0 / 3.14 - cvmix_variables % lon = mesh % lonCell % array(iCell) * 180.0 / 3.14 - cvmix_variables % surf_fric = diagnostics % surfaceFrictionVelocity % array(iCell) - cvmix_variables % surf_buoy = diagnostics % buoyancyForcingOBL % array(iCell) - -! write(stdoutUnit,*) 'TDR: zTop',maxval(diagnostics % zTop % array(1:nVertLevels,iCell)) -! write(stdoutUnit,*) 'TDR: bottomDepth',maxval(mesh % bottomDepth % array(:)) - - ! fill zw_iface with interface coordinates - cvmix_variables % zw_iface(1:nVertLevels) = diagnostics % zTop % array(1:nVertLevels,iCell) - cvmix_variables % zw_iface(nVertLevels+1) = -mesh % bottomDepth % array(iCell) - -! write(stdoutUnit,*) 'TDR: zw_iface',cvmix_variables % zw_iface(:) - - ! point remainder of cvmix_variables to MPAS arrays - cvmix_variables % zt => diagnostics % zMid % array(1:nVertLevels,iCell) - cvmix_variables % dzt => state % layerThickness % array(1:nVertLevels,iCell) - cvmix_variables % Rib => diagnostics % BulkRichardsonNumber % array(1:nVertLevels,iCell) - - ! compute the boundary layer depth -! write(stdoutUnit,*) 'TDR: calling cvmix_kpp_compute_OBL_depth' - call cvmix_kpp_compute_OBL_depth( cvmix_variables ) -! write(stdoutUnit,*) 'TDR: return cvmix_kpp_compute_OBL_depth' - -! write(stdoutUnit,*) 'TDR: OBL_depth, kOBL_depth',cvmix_variables % OBL_depth,cvmix_variables % kOBL_depth - - ! intent out of OBL_depth is boundary layer depth measured in meters and vertical index - diagnostics % boundaryLayerDepth % array(iCell) = cvmix_variables % OBL_depth - diagnostics % indexBoundaryLayerDepth % array(iCell) = cvmix_variables % kOBL_depth - -! write(stdoutUnit,*) 'TDR: OBL_depth',diagnostics % boundaryLayerDepth % array(iCell) - - ! given OBL and vertical profile of visc/diff, compute boundary layer mixing -! write(stdoutUnit,*) 'TDR: calling cvmix_coeffs_kpp' - call cvmix_coeffs_kpp( cvmix_variables ) -! write(stdoutUnit,*) 'TDR: return cvmix_coeffs_kpp' - - ! add convective mixing to vertical viscosity/diffusivity - vertViscTopOfCell(:,iCell) = vertViscTopOfCell(:,iCell) + cvmix_variables % visc_iface(:) - vertDiffTopOfCell(:,iCell) = vertDiffTopOfCell(:,iCell) + cvmix_variables % diff_iface(:,1) - - endif - - enddo - deallocate(cvmix_variables % visc_iface) - deallocate(cvmix_variables % diff_iface) - deallocate(cvmix_variables % zw_iface) - -! write(stdoutUnit,*) 'TDR: exiting ocn_vmix_coefs_cvmix_build' - - !-------------------------------------------------------------------- - - end subroutine ocn_vmix_coefs_cvmix_build!}}} - -!*********************************************************************** -! -! routine ocn_vmix_cvmix_init -! -!> \brief Initializes ocean vertical mixing quantities by using -!> \ get and puts into CVMix -!> \author Todd Ringler -!> \date 04 February 2013 -!> \version SVN:$Id$ -!> \details -!> This routine initializes a variety of quantities related to -!> vertical mixing in the ocean. Parameters are set by calling into CVMix -! -!----------------------------------------------------------------------- - - - subroutine ocn_vmix_cvmix_init(domain,err)!{{{ - - !-------------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! call individual init routines for each parameterization - ! - !----------------------------------------------------------------- - - implicit none - - type (domain_type), intent(inout) :: domain !< Input/Output: domain information - - integer, intent(out) :: err !< Output: error flag - - integer :: nVertLevels - type (block_type), pointer :: block - type (mesh_type), pointer :: mesh - - - ! - ! assume no errors during initialization and set to 1 when error is encountered - ! - err=0 - - ! - ! only initialize if CVMix is turned on - ! - if (.not.config_use_cvmix) return - - ! - ! When CVMix is turned on, all other vertical mixing schemes should be off - ! Test to make sure this is the case. - ! - ! test here, err=1 if a problem - - ! - ! pull nVertLevels out of the mesh structure - ! - block => domain % blocklist - do while (associated(block)) - mesh => block % mesh - nVertLevels = mesh % nVertLevels - block => block % next - end do - - ! - ! put global parameters into CVMix - ! - call cvmix_put(cvmix_global_params, 'max_nlev', nVertLevels) - call cvmix_put(cvmix_global_params, 'prandtl', config_cvmix_prandtl_number) - - ! - ! if using background values, put these into CVMix - ! - if (config_use_cvmix_background) then - call cvmix_init_bkgnd( & - bkgnd_diff = config_cvmix_background_diffusion, & - bkgnd_visc = config_cvmix_background_viscosity, & - CVmix_bkgnd_params_user = cvmix_background_params) -! write(stdoutUnit,*) 'cvmix_init_bkgnd',config_use_cvmix_background - endif - - ! - ! if using CVMix convection, put these into CVMix - ! - if (config_use_cvmix_convection) then - call cvmix_init_conv( & - convect_diff = config_cvmix_convective_diffusion, & - convect_visc = config_cvmix_convective_viscosity, & - CVmix_conv_params_user = cvmix_conv_params) -! write(stdoutUnit,*) 'cvmix_init_conv',config_use_cvmix_convection - endif - - ! - ! if using CVMix convection, put these into CVMix - ! - if (config_use_cvmix_kpp) then - call cvmix_init_kpp ( CVmix_kpp_params_user = cvmix_kpp_params ) -! write(stdoutUnit,*) 'cvmix_init_kpp',config_use_cvmix_kpp - endif - -! write(stdoutUnit,*) 'ocn_vmix_cvmix_init complete' - - !-------------------------------------------------------------------- - - end subroutine ocn_vmix_cvmix_init!}}} - -!*********************************************************************** - -end module ocn_vmix_cvmix - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| - -! vim: foldmethod=marker diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile new file mode 100644 index 0000000000..15f74e9d7f --- /dev/null +++ b/src/core_ocean/shared/Makefile @@ -0,0 +1,154 @@ +.SUFFIXES: .F .o +OBJS = mpas_ocn_init.o \ + mpas_ocn_gm.o \ + mpas_ocn_diagnostics.o \ + mpas_ocn_diagnostics_routines.o \ + mpas_ocn_thick_ale.o \ + mpas_ocn_equation_of_state.o \ + mpas_ocn_equation_of_state_jm.o \ + mpas_ocn_equation_of_state_linear.o \ + mpas_ocn_thick_hadv.o \ + mpas_ocn_thick_vadv.o \ + mpas_ocn_thick_surface_flux.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_vmix.o \ + mpas_ocn_vmix_coefs_const.o \ + mpas_ocn_vmix_coefs_rich.o \ + mpas_ocn_vmix_coefs_tanh.o \ + mpas_ocn_vmix_coefs_redi.o \ + mpas_ocn_vmix_cvmix.o \ + mpas_ocn_tendency.o \ + mpas_ocn_tracer_hmix.o \ + mpas_ocn_tracer_hmix_del2.o \ + mpas_ocn_tracer_hmix_del4.o \ + mpas_ocn_tracer_advection.o \ + mpas_ocn_tracer_nonlocalflux.o \ + mpas_ocn_tracer_short_wave_absorption.o \ + mpas_ocn_tracer_short_wave_absorption_jerlov.o \ + mpas_ocn_high_freq_thickness_hmix_del2.o \ + mpas_ocn_tracer_surface_flux.o \ + mpas_ocn_global_diagnostics.o \ + mpas_ocn_test.o \ + mpas_ocn_constants.o \ + mpas_ocn_forcing.o \ + mpas_ocn_forcing_bulk.o \ + mpas_ocn_forcing_restoring.o \ + mpas_ocn_time_average.o \ + mpas_ocn_time_average_coupled.o \ + mpas_ocn_sea_ice.o + +all: $(OBJS) + +mpas_ocn_init.o: mpas_ocn_constants.o + +mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_flux.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o + +mpas_ocn_diagnostics_routines.o: + +mpas_ocn_diagnostics.o: mpas_ocn_thick_ale.o mpas_ocn_diagnostics_routines.o mpas_ocn_equation_of_state.o mpas_ocn_gm.o + +mpas_ocn_thick_ale.o: + +mpas_ocn_global_diagnostics.o: + +mpas_ocn_time_average.o: + +mpas_ocn_time_average_coupled.o: mpas_ocn_constants.o + +mpas_ocn_thick_hadv.o: + +mpas_ocn_thick_vadv.o: + +mpas_ocn_thick_surface_flux.o: mpas_ocn_forcing.o + +mpas_ocn_gm.o: + +mpas_ocn_vel_pressure_grad.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_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_forcing.o + +mpas_ocn_vel_forcing_windstress.o: + +mpas_ocn_vel_forcing_rayleigh.o: + +mpas_ocn_vel_coriolis.o: + +mpas_ocn_tracer_hmix.o: mpas_ocn_tracer_hmix_del2.o mpas_ocn_tracer_hmix_del4.o + +mpas_ocn_tracer_hmix_del2.o: + +mpas_ocn_tracer_hmix_del4.o: + +mpas_ocn_tracer_advection.o: + +mpas_ocn_high_freq_thickness_hmix_del2.o: + +mpas_ocn_tracer_nonlocalflux.o: + +mpas_ocn_tracer_surface_flux.o: mpas_ocn_forcing.o + +mpas_ocn_tracer_short_wave_absorption.o: mpas_ocn_tracer_short_wave_absorption_jerlov.o + +mpas_ocn_tracer_short_wave_absorption_jerlov.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_vmix_cvmix.o mpas_ocn_vmix_coefs_redi.o + +mpas_ocn_vmix_coefs_const.o: + +mpas_ocn_vmix_coefs_rich.o: mpas_ocn_equation_of_state.o + +mpas_ocn_vmix_coefs_tanh.o: + +mpas_ocn_vmix_cvmix.o: + +mpas_ocn_vmix_coefs_redi.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_jm.o: + +mpas_ocn_equation_of_state_linear.o: + +mpas_ocn_test.o: + +mpas_ocn_constants.o: + +mpas_ocn_forcing.o: mpas_ocn_constants.o mpas_ocn_forcing_bulk.o mpas_ocn_forcing_restoring.o + +mpas_ocn_forcing_bulk.o: + +mpas_ocn_forcing_restoring.o: + +mpas_ocn_sea_ice.o: + + +clean: + $(RM) *.o *.i *.mod *.f90 + +.F.o: + $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) +endif diff --git a/src/core_ocean/mpas_ocn_constants.F b/src/core_ocean/shared/mpas_ocn_constants.F similarity index 96% rename from src/core_ocean/mpas_ocn_constants.F rename to src/core_ocean/shared/mpas_ocn_constants.F index 7a21423824..ca1dd75b33 100644 --- a/src/core_ocean/mpas_ocn_constants.F +++ b/src/core_ocean/shared/mpas_ocn_constants.F @@ -12,7 +12,6 @@ !> \brief MPAS ocean specific constants !> \author Doug Jacobsen !> \date 04/25/12 -!> \version SVN:$Id:$ !> \details !> This module contains constants specific to the ocean model. ! @@ -20,6 +19,7 @@ module ocn_constants + use mpas_grid_types use mpas_kind_types #ifdef MPAS_CESM @@ -30,6 +30,9 @@ module ocn_constants implicit none save + type (mpas_pool_type), pointer :: ocnConfigs + type (mpas_pool_type), pointer :: ocnPackages + real (kind=RKIND), public :: & rho_air ,&! ambient air density (kg/m^3) rho_fw ,&! density of fresh water (kg/m^3) @@ -77,15 +80,18 @@ module ocn_constants !> \brief Initializes the ocean constants !> \author Doug Jacobsen !> \date 04/25/12 -!> \version SVN:$Id$ !> \details !> This routine sets up constants for use in the ocean model. ! !----------------------------------------------------------------------- - - subroutine ocn_constants_init()!{{{ + subroutine ocn_constants_init(configPool, packagePool)!{{{ + type (mpas_pool_type), pointer :: configPool + type (mpas_pool_type), pointer :: packagePool integer :: n + ocnConfigs => configPool + ocnPackages => packagePool + !----------------------------------------------------------------------- ! ! physical constants diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F new file mode 100644 index 0000000000..c42cef1c84 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -0,0 +1,1395 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_diagnostics +! +!> \brief MPAS ocean diagnostics driver +!> \author Mark Petersen +!> \date 23 September 2011 +!> \details +!> This module contains the routines for computing +!> diagnostic variables, and other quantities such as vertAleTransportTop. +! +!----------------------------------------------------------------------- + +module ocn_diagnostics + + use mpas_grid_types + use mpas_constants + use mpas_timer + use mpas_vector_reconstruction + + use ocn_constants + use ocn_gm + use ocn_equation_of_state + use ocn_thick_ale + use ocn_diagnostics_routines + + implicit none + private + save + + type (timer_node), pointer :: diagEOSTimer + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_diagnostic_solve, & + ocn_vert_transport_velocity_top, & + ocn_fuperp, & + ocn_filter_btr_mode_vel, & + ocn_filter_btr_mode_tend_vel, & + ocn_reconstruct_gm_vectors, & + ocn_diagnostics_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + integer :: ke_cell_flag, ke_vertex_flag + real (kind=RKIND) :: fCoef + real (kind=RKIND), pointer :: coef_3rd_order + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_diagnostic_solve +! +!> \brief Computes diagnostic variables +!> \author Mark Petersen +!> \date 23 September 2011 +!> \details +!> This routine computes the diagnostic variables for the ocean +! +!----------------------------------------------------------------------- + + subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevelIn)!{{{ + + real (kind=RKIND), intent(in) :: dt !< Input: Time step + type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(inout) :: diagnosticsPool !< Input: diagnostic fields derived from State + type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables + integer, intent(in), optional :: timeLevelIn !< Input: Time level in state + + integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j + integer :: boundaryMask, velMask, err + integer, pointer :: nEdgesSolve, nCells, nEdges, nVertices, nVertLevels, vertexDegree + + 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, layerThicknessVertex, coef, & + shearMean, shearSquared, factor, delU2, sumSurfaceLayer, surfaceLayerDepth, rSurfaceLayer + + real (kind=RKIND), dimension(:), allocatable:: pTop, div_hu,div_huTransport,div_huGMBolus + + real (kind=RKIND), dimension(:), pointer :: & + bottomDepth, fVertex, dvEdge, dcEdge, areaCell, areaTriangle, ssh, seaSurfacePressure + real (kind=RKIND), dimension(:,:), pointer :: & + weightsOnEdge, kiteAreasOnVertex, layerThicknessEdge, layerThickness, normalVelocity, normalTransportVelocity, normalGMBolusVelocity, tangentialVelocity, pressure,& + circulation, kineticEnergyCell, montgomeryPotential, vertAleTransportTop, zMid, zTop, divergence, & + relativeVorticity, relativeVorticityCell, & + normalizedPlanetaryVorticityEdge, normalizedPlanetaryVorticityVertex, & + normalizedRelativeVorticityEdge, normalizedRelativeVorticityVertex, normalizedRelativeVorticityCell, & + density, displacedDensity, potentialDensity, temperature, salinity, kineticEnergyVertex, kineticEnergyVertexOnCells, & + vertVelocityTop, vertTransportVelocityTop, vertGMBolusVelocityTop, BruntVaisalaFreqTop, & + vorticityGradientNormalComponent, vorticityGradientTangentialComponent, gradSSH, RiTopOfCell, & + inSituThermalExpansionCoeff, inSituSalineContractionCoeff + + real (kind=RKIND), dimension(:,:,:), pointer :: tracers, derivTwo + character :: c1*6 + + real (kind=RKIND), dimension(:,:), pointer :: tracersSurfaceValue + real (kind=RKIND), dimension(:,:), pointer :: tracersSurfaceLayerValue + real (kind=RKIND), dimension(:), pointer :: boundaryLayerDepth, boundaryLayerDepthEdge + real (kind=RKIND), dimension(:), pointer :: normalVelocitySurfaceLayer + real (kind=RKIND), dimension(:), pointer :: indexSurfaceLayerDepth + + type (field2DReal), pointer :: kineticEnergyVertexField, kineticEnergyVertexOnCellsField + type (field2DReal), pointer :: normalizedRelativeVorticityVertexField, normalizedPlanetaryVorticityVertexField + type (field2DReal), pointer :: vorticityGradientNormalComponentField, vorticityGradientTangentialComponentField + + integer :: timeLevel + integer, pointer :: indexTemperature, indexSalinity + logical, pointer :: config_use_cvmix_kpp + real (kind=RKIND), pointer :: config_density0, config_apvm_scale_factor, config_coef_3rd_order, config_cvmix_kpp_surface_layer_extent + character (len=StrKIND), pointer :: config_pressure_gradient_type + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + call mpas_pool_get_config(ocnConfigs, 'config_apvm_scale_factor', config_apvm_scale_factor) + call mpas_pool_get_config(ocnConfigs, 'config_pressure_gradient_type', config_pressure_gradient_type) + call mpas_pool_get_config(ocnConfigs, 'config_coef_3rd_order', config_coef_3rd_order) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_surface_layer_extent', config_cvmix_kpp_surface_layer_extent) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + + call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(statePool, 'ssh', ssh, timeLevel) + + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) + call mpas_pool_get_array(diagnosticsPool, 'divergence', divergence) + call mpas_pool_get_array(diagnosticsPool, 'circulation', circulation) + call mpas_pool_get_array(diagnosticsPool, 'relativeVorticity', relativeVorticity) + call mpas_pool_get_array(diagnosticsPool, 'relativeVorticityCell', relativeVorticityCell) + call mpas_pool_get_array(diagnosticsPool, 'normalizedPlanetaryVorticityEdge', normalizedPlanetaryVorticityEdge) + call mpas_pool_get_array(diagnosticsPool, 'normalizedRelativeVorticityEdge', normalizedRelativeVorticityEdge) + call mpas_pool_get_array(diagnosticsPool, 'normalizedRelativeVorticityCell', normalizedRelativeVorticityCell) + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'displacedDensity', displacedDensity) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', potentialDensity) + call mpas_pool_get_array(diagnosticsPool, 'montgomeryPotential', montgomeryPotential) + call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) + call mpas_pool_get_array(diagnosticsPool, 'BruntVaisalaFreqTop', BruntVaisalaFreqTop) + call mpas_pool_get_array(diagnosticsPool, 'tangentialVelocity', tangentialVelocity) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) + call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'vertTransportVelocityTop', vertTransportVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'vertGMBolusVelocityTop', vertGMBolusVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'gradSSH', gradSSH) + call mpas_pool_get_array(diagnosticsPool, 'RiTopOfCell', RiTopOfCell) + + call mpas_pool_get_array(meshPool, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + call mpas_pool_get_array(meshPool, 'derivTwo', derivTwo) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) + call mpas_pool_get_array(meshPool, 'kiteIndexOnCell', kiteIndexOnCell) + call mpas_pool_get_array(meshPool, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnVertex', edgeSignOnVertex) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(diagnosticsPool, 'tracersSurfaceValue', tracersSurfaceValue) + call mpas_pool_get_array(diagnosticsPool, 'tracersSurfaceLayerValue', tracersSurfaceLayerValue) + call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) + call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepthEdge', boundaryLayerDepthEdge) + call mpas_pool_get_array(diagnosticsPool, 'normalVelocitySurfaceLayer', normalVelocitySurfaceLayer) + call mpas_pool_get_array(diagnosticsPool, 'indexSurfaceLayerDepth', indexSurfaceLayerDepth) + + ! + ! Compute height on cell edges at velocity locations + ! Namelist options control the order of accuracy of the reconstructed layerThicknessEdge value + ! + + ! initialize layerThicknessEdge to avoid divide by zero and NaN problems. + layerThicknessEdge = -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) + layerThicknessEdge(k,iEdge) = 0.5 * (layerThickness(k,cell1) + layerThickness(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. + ! + normalVelocity(:,nEdges+1) = -1e34 + layerThickness(:,nCells+1) = -1e34 + tracers(indexTemperature,:,nCells+1) = -1e34 + tracers(indexSalinity,:,nCells+1) = -1e34 + + divergence(:,:) = 0.0 + vertVelocityTop(:,:)=0.0 + kineticEnergyCell(:,:) = 0.0 + tangentialVelocity(:,:) = 0.0 + + call ocn_relativeVorticity_circulation(relativeVorticity, circulation, meshPool, normalVelocity, err) + + relativeVorticityCell(:,:) = 0.0 + 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) + relativeVorticityCell(k, iCell) = relativeVorticityCell(k, iCell) + kiteAreasOnVertex(j, iVertex) * relativeVorticity(k, iVertex) * invAreaCell1 + end do + end do + end do + + ! + ! Compute divergence, kinetic energy, and vertical velocity + ! + allocate(div_hu(nVertLevels),div_huTransport(nVertLevels),div_huGMBolus(nVertLevels)) + do iCell = 1, nCells + div_hu(:) = 0.0 + div_huTransport(:) = 0.0 + div_huGMBolus(:) = 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) * normalVelocity(k, iEdge) * invAreaCell1 + + divergence(k, iCell) = divergence(k, iCell) - edgeSignOnCell(i, iCell) * r_tmp + div_hu(k) = div_hu(k) - layerThicknessEdge(k, iEdge) * edgeSignOnCell(i, iCell) * r_tmp + kineticEnergyCell(k, iCell) = kineticEnergyCell(k, iCell) + 0.25 * r_tmp * dcEdge(iEdge) * normalVelocity(k,iEdge) + + ! Compute vertical velocity from the horizontal total transport + div_huTransport(k) = div_huTransport(k) - layerThicknessEdge(k, iEdge) * edgeSignOnCell(i, iCell) * dvEdge(iEdge) * normalTransportVelocity(k, iEdge) * invAreaCell1 + ! Compute vertical velocity from the horizontal GM Bolus velocity + div_huGMBolus(k) = div_huGMBolus(k) - layerThicknessEdge(k, iEdge) * edgeSignOnCell(i, iCell) * dvEdge(iEdge) * normalGMBolusVelocity(k, iEdge) * invAreaCell1 + 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) + vertTransportVelocityTop(k,iCell) = vertTransportVelocityTop(k+1,iCell) - div_huTransport(k) + vertGMBolusVelocityTop(k,iCell) = vertGMBolusVelocityTop(k+1,iCell) - div_huGMBolus(k) + end do + end do + deallocate(div_hu,div_huTransport,div_huGMBolus) + + do iEdge = 1, nEdges + ! Compute v (tangential) velocities + do i = 1, nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(i,iEdge) + do k = 1, maxLevelEdgeTop(iEdge) + tangentialVelocity(k,iEdge) = tangentialVelocity(k,iEdge) + weightsOnEdge(i,iEdge) * normalVelocity(k, eoe) + end do + end do + end do + + ! + ! Compute kinetic energy + ! + call mpas_pool_get_field(scratchPool, 'kineticEnergyVertex', kineticEnergyVertexField) + call mpas_pool_get_field(scratchPool, 'kineticEnergyVertexOnCells', kineticEnergyVertexOnCellsField) + call mpas_allocate_scratch_field(kineticEnergyVertexField, .true.) + call mpas_allocate_scratch_field(kineticEnergyVertexOnCellsField, .true.) + kineticEnergyVertex => kineticEnergyVertexField % array + kineticEnergyVertexOnCells => kineticEnergyVertexOnCellsField % array + kineticEnergyVertex(:,:) = 0.0; + kineticEnergyVertexOnCells(:,:) = 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 + kineticEnergyVertex(k, iVertex) = kineticEnergyVertex(k, iVertex) + r_tmp * normalVelocity(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 + kineticEnergyVertexOnCells(k, iCell) = kineticEnergyVertexOnCells(k, iCell) + kiteAreasOnVertex(j, iVertex) * kineticEnergyVertex(k, iVertex) * invAreaCell1 + end do + end do + end do + + ! + ! Compute kinetic energy in each cell by blending kineticEnergyCell and kineticEnergyVertexOnCells + ! + do iCell = 1, nCells * ke_vertex_flag + do k = 1, nVertLevels + kineticEnergyCell(k,iCell) = 5.0 / 8.0 * kineticEnergyCell(k,iCell) + 3.0 / 8.0 * kineticEnergyVertexOnCells(k,iCell) + end do + end do + + call mpas_deallocate_scratch_field(kineticEnergyVertexField, .true.) + call mpas_deallocate_scratch_field(kineticEnergyVertexOnCellsField, .true.) + + ! + ! Compute normalized relative and planetary vorticity + ! + call mpas_pool_get_field(scratchPool, 'normalizedRelativeVorticityVertex', normalizedRelativeVorticityVertexField) + call mpas_pool_get_field(scratchPool, 'normalizedPlanetaryVorticityVertex', normalizedPlanetaryVorticityVertexField) + call mpas_allocate_scratch_field(normalizedRelativeVorticityVertexField, .true.) + call mpas_allocate_scratch_field(normalizedPlanetaryVorticityVertexField, .true.) + normalizedPlanetaryVorticityVertex => normalizedPlanetaryVorticityVertexField % array + normalizedRelativeVorticityVertex => normalizedRelativeVorticityVertexField % array + do iVertex = 1, nVertices + invAreaTri1 = 1.0 / areaTriangle(iVertex) + do k = 1, maxLevelVertexBot(iVertex) + layerThicknessVertex = 0.0 + do i = 1, vertexDegree + layerThicknessVertex = layerThicknessVertex + layerThickness(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex) + end do + layerThicknessVertex = layerThicknessVertex * invAreaTri1 + + normalizedRelativeVorticityVertex(k,iVertex) = relativeVorticity(k,iVertex) / layerThicknessVertex + normalizedPlanetaryVorticityVertex(k,iVertex) = fVertex(iVertex) / layerThicknessVertex + end do + end do + + normalizedRelativeVorticityEdge(:,:) = 0.0 + normalizedPlanetaryVorticityEdge(:,:) = 0.0 + do iEdge = 1, nEdges + vertex1 = verticesOnEdge(1, iEdge) + vertex2 = verticesOnEdge(2, iEdge) + do k = 1, maxLevelEdgeBot(iEdge) + normalizedRelativeVorticityEdge(k, iEdge) = 0.5 * (normalizedRelativeVorticityVertex(k, vertex1) + normalizedRelativeVorticityVertex(k, vertex2)) + normalizedPlanetaryVorticityEdge(k, iEdge) = 0.5 * (normalizedPlanetaryVorticityVertex(k, vertex1) + normalizedPlanetaryVorticityVertex(k, vertex2)) + end do + end do + + normalizedRelativeVorticityCell(:,:) = 0.0 + 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) + normalizedRelativeVorticityCell(k, iCell) = normalizedRelativeVorticityCell(k, iCell) & + + kiteAreasOnVertex(j, iVertex) * normalizedRelativeVorticityVertex(k, iVertex) * invAreaCell1 + end do + end do + end do + + ! Diagnostics required for the Anticipated Potential Vorticity Method (apvm). + if (config_apvm_scale_factor>1e-10) then + + call mpas_pool_get_field(scratchPool, 'vorticityGradientNormalComponent', vorticityGradientNormalComponentField) + call mpas_pool_get_field(scratchPool, 'vorticityGradientTangentialComponent', vorticityGradientTangentialComponentField) + call mpas_allocate_scratch_field(vorticityGradientNormalComponentField, .true.) + call mpas_allocate_scratch_field(vorticityGradientTangentialComponentField, .true.) + vorticityGradientNormalComponent => vorticityGradientNormalComponentField % array + vorticityGradientTangentialComponent => vorticityGradientTangentialComponentField % array + + 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 the gradient for all edges bounding real cells ) + do k=1,maxLevelEdgeTop(iEdge) + vorticityGradientNormalComponent(k,iEdge) = & + (normalizedRelativeVorticityCell(k,cell2) - normalizedRelativeVorticityCell(k,cell1)) * invLength + enddo + + invLength = 1.0 / dvEdge(iEdge) + ! Compute gradient of PV in the tangent direction + ! ( this computes the gradient at all edges bounding real cells and distance-1 ghost cells ) + do k = 1,maxLevelEdgeBot(iEdge) + vorticityGradientTangentialComponent(k,iEdge) = & + (normalizedRelativeVorticityVertex(k,vertex2) - normalizedRelativeVorticityVertex(k,vertex1)) * invLength + enddo + + enddo + + ! + ! Modify PV edge with upstream bias. + ! + do iEdge = 1,nEdges + do k = 1,maxLevelEdgeBot(iEdge) + normalizedRelativeVorticityEdge(k,iEdge) = normalizedRelativeVorticityEdge(k,iEdge) & + - config_apvm_scale_factor * dt * & + ( normalVelocity(k,iEdge) * vorticityGradientNormalComponent(k,iEdge) & + + tangentialVelocity(k,iEdge) * vorticityGradientTangentialComponent(k,iEdge) ) + enddo + enddo + call mpas_deallocate_scratch_field(vorticityGradientNormalComponentField, .true.) + call mpas_deallocate_scratch_field(vorticityGradientTangentialComponentField, .true.) + + endif + call mpas_deallocate_scratch_field(normalizedRelativeVorticityVertexField, .true.) + call mpas_deallocate_scratch_field(normalizedPlanetaryVorticityVertexField, .true.) + + ! + ! equation of state + ! + call mpas_timer_start("equation of state", .false., diagEOSTimer) + + ! compute in-place density + if (config_pressure_gradient_type.eq.'common_level_eos') then + ! only compute EOS derivatives if needed. + call mpas_pool_get_array(diagnosticsPool, 'inSituThermalExpansionCoeff',inSituThermalExpansionCoeff) + call mpas_pool_get_array(diagnosticsPool, 'inSituSalineContractionCoeff', inSituSalineContractionCoeff) + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 0, 'relative', density, err, & + inSituThermalExpansionCoeff, inSituSalineContractionCoeff, timeLevelIn=timeLevel) + else + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 0, 'relative', density, err, & + timeLevelIn=timeLevel) + endif + + ! compute potentialDensity, the density displaced adiabatically to the mid-depth of top layer. + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 1, 'absolute', potentialDensity, err, timeLevelIn=timeLevel) + + ! compute displacedDensity, density displaced adiabatically to the mid-depth one layer deeper. + ! That is, layer k has been displaced to the depth of layer k+1. + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 1, 'relative', displacedDensity, err, timeLevelIn=timeLevel) + + call mpas_timer_stop("equation of state", diagEOSTimer) + + ! + ! Pressure + ! This section must be placed in the code after computing the density. + ! + if (config_pressure_gradient_type.eq.'MontgomeryPotential') then + + ! use Montgomery Potential when layers are isopycnal. + ! However, one may use 'pressure_and_zmid' when layers are isopycnal as well. + ! 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 + ! At top layer it is g*SSH, where SSH may be off by a + ! constant (ie, bottomDepth can be relative to top or bottom) + montgomeryPotential(1,iCell) = gravity & + * (bottomDepth(iCell) + sum(layerThickness(1:nVertLevels,iCell))) + + do k = 2, nVertLevels + pTop(k) = pTop(k-1) + density(k-1,iCell)*gravity* layerThickness(k-1,iCell) + + ! from delta M = p delta / density + montgomeryPotential(k,iCell) = montgomeryPotential(k-1,iCell) & + + pTop(k)*(1.0/density(k,iCell) - 1.0/density(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) + density(1,iCell)*gravity & + * 0.5*layerThickness(1,iCell) + + do k = 2, maxLevelCell(iCell) + pressure(k,iCell) = pressure(k-1,iCell) & + + 0.5*gravity*( density(k-1,iCell)*layerThickness(k-1,iCell) & + + density(k ,iCell)*layerThickness(k ,iCell)) + end do + + ! Compute zMid, the z-coordinate of the middle of the layer. + ! Compute zTop, the z-coordinate of the top of the layer. + ! 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*layerThickness(k,iCell) + zTop(k:nVertLevels,iCell) = -bottomDepth(iCell) + layerThickness(k,iCell) + + do k = maxLevelCell(iCell)-1, 1, -1 + zMid(k,iCell) = zMid(k+1,iCell) & + + 0.5*( layerThickness(k+1,iCell) & + + layerThickness(k ,iCell)) + zTop(k,iCell) = zTop(k+1,iCell) & + + layerThickness(k ,iCell) + end do + + ! copy zTop(1,iCell) into sea-surface height array + ssh(iCell) = zTop(1,iCell) + + end do + + endif + + ! + ! Brunt-Vaisala frequency (this has units of s^{-2}) + ! + coef = -gravity / config_density0 + do iCell = 1, nCells + BruntVaisalaFreqTop(1,iCell) = 0.0 + do k = 2, maxLevelCell(iCell) + BruntVaisalaFreqTop(k,iCell) = coef * (displacedDensity(k-1,iCell) - density(k,iCell)) & + / (zMid(k-1,iCell) - zMid(k,iCell)) + end do + end do + + ! + ! Gradient Richardson number + ! + RiTopOfCell = 100.0 + do iCell=1,nCells + invAreaCell1 = 1.0 / areaCell(iCell) + do k=2,maxLevelCell(iCell) + shearSquared = 0.0 + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + factor = 0.5 * dcEdge(iEdge) * dvEdge(iEdge) * invAreaCell1 + delU2 = (normalVelocity(k-1,iEdge) - normalVelocity(k,iEdge))**2 + shearSquared = shearSquared + factor * delU2 + enddo + shearMean = sqrt(shearSquared) + shearMean = shearMean / (zMid(k-1,iCell) - zMid(k,iCell)) + RiTopOfCell(k,iCell) = BruntVaisalaFreqTop(k,iCell) / (shearMean**2 + 1.0e-10) + end do + RiTopOfCell(1,iCell) = RiTopOfCell(2,iCell) + end do + + ! + ! extrapolate tracer values to ocean surface + ! this eventually be a modelled process + ! at present, just copy k=1 tracer values onto surface values + ! field will be updated below is better approximations are available + tracersSurfaceValue(:,:) = tracers(:,1,:) + normalVelocitySurfaceLayer(:) = normalVelocity(1,:) + + ! + ! average tracer values over the ocean surface layer + ! the ocean surface layer is generally assumed to be about 0.1 of the boundary layer depth + if(config_use_cvmix_kpp) then + tracersSurfaceLayerValue(:,:) = 0.0 + indexSurfaceLayerDepth(:) = -9.e30 + do iCell=1,nCells + surfaceLayerDepth = boundaryLayerDepth(iCell) * config_cvmix_kpp_surface_layer_extent + sumSurfaceLayer=0.0 + do k=1,maxLevelCell(iCell) + sumSurfaceLayer = sumSurfaceLayer + layerThickness(k,iCell) + if(sumSurfaceLayer.gt.surfaceLayerDepth) then + sumSurfaceLayer = sumSurfaceLayer - layerThickness(k,iCell) + rSurfaceLayer = int(k-1) + (surfaceLayerDepth-sumSurfaceLayer)/layerThickness(k,iCell) + indexSurfaceLayerDepth(iCell) = rSurfaceLayer + exit + endif + end do + sumSurfaceLayer = 0.0 + do k=1,int(rSurfaceLayer) + sumSurfaceLayer = sumSurfaceLayer + layerThickness(k,iCell) + tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) + tracers(:,k,iCell)*layerThickness(k,iCell) + enddo + k=int(rSurfaceLayer)+1 + sumSurfaceLayer = sumSurfaceLayer + fraction(rSurfaceLayer)*layerThickness(k,iCell) + tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) + fraction(rSurfaceLayer)*tracers(:,k,iCell)*layerThickness(k,iCell) + tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) / sumSurfaceLayer + enddo + endif + + ! + ! average normal velocity values over the ocean surface layer + ! the ocean surface layer is generally assumed to be about 0.1 of the boundary layer depth + ! + if (config_use_cvmix_kpp) then + normalVelocitySurfaceLayer(:) = 0.0 + do iEdge=1,nEdges + cell1=cellsOnEdge(1,iEdge) + cell2=cellsOnEdge(2,iEdge) + boundaryLayerDepthEdge(iEdge) = 0.5*( boundaryLayerDepth(cell1)+boundaryLayerDepth(cell2) ) + surfaceLayerDepth = boundaryLayerDepthEdge(iEdge) * config_cvmix_kpp_surface_layer_extent + sumSurfaceLayer=0.0 + do k=1,maxLevelEdgeTop(iEdge) + rSurfaceLayer = k + sumSurfaceLayer = sumSurfaceLayer + layerThicknessEdge(k,iEdge) + if(sumSurfaceLayer.gt.surfaceLayerDepth) then + sumSurfaceLayer = sumSurfaceLayer - layerThicknessEdge(k,iCell) + rSurfaceLayer = int(k-1) + (surfaceLayerDepth-sumSurfaceLayer)/layerThicknessEdge(k,iCell) + exit + endif + end do + sumSurfaceLayer = 0.0 + do k=1,int(rSurfaceLayer) + sumSurfaceLayer = sumSurfaceLayer + layerThicknessEdge(k,iEdge) + normalVelocitySurfaceLayer(iEdge) = normalVelocitySurfaceLayer(iEdge) + normalVelocity(k,iEdge)*layerThicknessEdge(k,iEdge) + enddo + k=int(rSurfaceLayer)+1 + if(k.le.maxLevelEdgeTop(iEdge)) then + sumSurfaceLayer = sumSurfaceLayer + fraction(rSurfaceLayer)*layerThickness(k,iCell) + normalVelocitySurfaceLayer(iEdge) = normalVelocitySurfaceLayer(iEdge) + fraction(rSurfaceLayer)*normalVelocity(k,iEdge)*layerThicknessEdge(k,iEdge) + endif + if (maxLevelEdgeTop(iEdge) .gt. 0) then + normalVelocitySurfaceLayer(iEdge) = normalVelocitySurfaceLayer(iEdge) / sumSurfaceLayer + end if + enddo + endif ! if config_use_cvmix_kpp + + ! + ! compute fields used as intent(in) to CVMix/KPP + if (config_use_cvmix_kpp) then + call computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevel) + endif + +#ifdef MPAS_CESM + do iEdge = 1, nEdgesSolve + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + + gradSSH(1, iEdge) = (ssh(cell2) - ssh(cell1)) / dcEdge(iEdge) + end do +#endif + + end subroutine ocn_diagnostic_solve!}}} + +!*********************************************************************** +! +! routine ocn_vert_transport_velocity_top +! +!> \brief Computes vertical transport +!> \author Mark Petersen +!> \date August 2013 +!> \details +!> This routine computes the vertical transport through the top of each +!> cell. +! +!----------------------------------------------------------------------- + subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerThickness, layerThicknessEdge, & + normalVelocity, oldSSH, newHighFreqThickness, dt, vertAleTransportTop, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: horizonal mesh information + + type (mpas_pool_type), intent(in) :: & + verticalMeshPool !< Input: vertical mesh information + + real (kind=RKIND), dimension(:,:), intent(in) :: & + oldLayerThickness !< Input: layer thickness at old time + + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThicknessEdge !< Input: layerThickness interpolated to an edge + + real (kind=RKIND), dimension(:,:), intent(in) :: & + normalVelocity !< Input: transport + + real (kind=RKIND), dimension(:), intent(in) :: & + oldSSH !< Input: sea surface height at old time + + real (kind=RKIND), dimension(:,:), intent(in) :: & + newHighFreqThickness !< Input: high frequency thickness. Alters ALE thickness. + + real (kind=RKIND), intent(in) :: & + dt !< Input: time step + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:), intent(out) :: & + vertAleTransportTop !< Output: vertical transport at top of cell + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iEdge, iCell, k, i + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, & + maxLevelCell, maxLevelEdgeBot + integer, dimension(:,:), pointer :: edgesOnCell, edgeSignOnCell + + real (kind=RKIND) :: flux, invAreaCell + real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell + real (kind=RKIND), dimension(:), allocatable :: & + div_hu_btr !> barotropic divergence of (thickness*velocity) + real (kind=RKIND), dimension(:,:), allocatable :: & + ALE_Thickness, & !> ALE thickness at new time + div_hu !> divergence of (thickness*velocity) + + character (len=StrKIND), pointer :: config_vert_coord_movement + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_vert_coord_movement', config_vert_coord_movement) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + if (config_vert_coord_movement.eq.'impermeable_interfaces') then + vertAleTransportTop=0.0 + return + end if + + allocate(div_hu(nVertLevels,nCells), div_hu_btr(nCells), ALE_Thickness(nVertLevels,nCells)) + + ! + ! thickness-weighted divergence and barotropic divergence + ! + ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3. + do iCell = 1, nCells + div_hu(:,iCell) = 0.0 + div_hu_btr(iCell) = 0.0 + invAreaCell = 1.0 / areaCell(iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + + do k = 1, maxLevelEdgeBot(iEdge) + flux = layerThicknessEdge(k, iEdge) * normalVelocity(k, iEdge) * dvEdge(iEdge) * edgeSignOnCell(i, iCell) * invAreaCell + div_hu(k,iCell) = div_hu(k,iCell) - flux + div_hu_btr(iCell) = div_hu_btr(iCell) - flux + end do + end do + + enddo + + ! + ! Compute desired thickness at new time + ! + call ocn_ALE_thickness(meshPool, verticalMeshPool, oldSSH, div_hu_btr, newHighFreqThickness, dt, ALE_thickness, err) + + ! + ! Vertical transport through layer interfaces + ! + ! Vertical transport through layer interface at top and bottom is zero. + ! Here we are using solving the continuity equation for vertAleTransportTop ($w^t$), + ! and using ALE_Thickness for thickness at the new time. + + do iCell = 1,nCells + vertAleTransportTop(1,iCell) = 0.0 + vertAleTransportTop(maxLevelCell(iCell)+1,iCell) = 0.0 + do k = maxLevelCell(iCell),2,-1 + vertAleTransportTop(k,iCell) = vertAleTransportTop(k+1,iCell) - div_hu(k,iCell) & + - (ALE_Thickness(k,iCell) - oldLayerThickness(k,iCell))/dt + end do + end do + + deallocate(div_hu, div_hu_btr, ALE_Thickness) + + end subroutine ocn_vert_transport_velocity_top!}}} + +!*********************************************************************** +! +! routine ocn_fuperp +! +!> \brief Computes f u_perp +!> \author Mark Petersen +!> \date 23 September 2011 +!> \details +!> This routine computes f u_perp for the ocean +! +!----------------------------------------------------------------------- + + subroutine ocn_fuperp(statePool, meshPool, timeLevelIn)!{{{ + + type (mpas_pool_type), intent(inout) :: statePool !< Input/Output: State information + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + integer, intent(in), optional :: timeLevelIn !< Input: Input time level for state pool + + integer :: iEdge, cell1, cell2, eoe, i, j, k + integer, pointer :: nEdgesSolve + real (kind=RKIND), dimension(:), pointer :: fEdge + real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, normalVelocity, normalBaroclinicVelocity + type (dm_info) :: dminfo + + integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnEdge + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge + + integer :: timeLevel + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_timer_start("ocn_fuperp") + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocity, timeLevel) + + call mpas_pool_get_array(meshPool, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnEdge', edgesOnEdge) + + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + ! + ! Put f*normalBaroclinicVelocity^{perp} in u as a work variable + ! + do iEdge = 1, nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k = 1, maxLevelEdgeTop(iEdge) + + normalVelocity(k,iEdge) = 0.0 + do j = 1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(j,iEdge) + normalVelocity(k,iEdge) = normalVelocity(k,iEdge) + weightsOnEdge(j,iEdge) * normalBaroclinicVelocity(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_vel +! +!> \brief filters barotropic mode out of the velocity variable. +!> \author Mark Petersen +!> \date 23 September 2011 +!> \details +!> This routine filters barotropic mode out of the velocity variable. +! +!----------------------------------------------------------------------- + subroutine ocn_filter_btr_mode_vel(statePool, diagnosticsPool, meshPool, timeLevelIn)!{{{ + + type (mpas_pool_type), intent(inout) :: statePool !< Input/Output: State information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostics information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state pool + + integer :: iEdge, k + integer, pointer :: nEdges + real (kind=RKIND) :: vertSum, normalThicknessFluxSum, thicknessSum + real (kind=RKIND), dimension(:,:), pointer :: layerThicknessEdge, normalVelocity + integer, dimension(:), pointer :: maxLevelEdgeTop + + integer :: timeLevel + + call mpas_timer_start("ocn_filter_btr_mode_vel") + + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + do iEdge = 1, nEdges + + ! thicknessSum is initialized outside the loop because on land boundaries + ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a + ! nonzero value to avoid a NaN. + normalThicknessFluxSum = layerThicknessEdge(1,iEdge) * normalVelocity(1,iEdge) + thicknessSum = layerThicknessEdge(1,iEdge) + + do k = 2, maxLevelEdgeTop(iEdge) + normalThicknessFluxSum = normalThicknessFluxSum + layerThicknessEdge(k,iEdge) * normalVelocity(k,iEdge) + thicknessSum = thicknessSum + layerThicknessEdge(k,iEdge) + enddo + + vertSum = normalThicknessFluxSum/thicknessSum + do k = 1, maxLevelEdgeTop(iEdge) + normalVelocity(k,iEdge) = normalVelocity(k,iEdge) - vertSum + enddo + enddo ! iEdge + + call mpas_timer_stop("ocn_filter_btr_mode_vel") + + end subroutine ocn_filter_btr_mode_vel!}}} + +!*********************************************************************** +! +! routine ocn_filter_btr_mode_tend_vel +! +!> \brief ocn_filters barotropic mode out of the velocity tendency +!> \author Mark Petersen +!> \date 23 September 2011 +!> \details +!> This routine filters barotropic mode out of the velocity tendency. +! +!----------------------------------------------------------------------- + subroutine ocn_filter_btr_mode_tend_vel(tendPool, statePool, diagnosticsPool, meshPool, timeLevelIn)!{{{ + + type (mpas_pool_type), intent(inout) :: tendPool !< Input/Output: Tendency information + type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostics information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state pool + + integer :: iEdge, k + integer, pointer :: nEdges + real (kind=RKIND) :: vertSum, normalThicknessFluxSum, thicknessSum + real (kind=RKIND), dimension(:,:), pointer :: layerThicknessEdge, tend_normalVelocity + + integer, dimension(:), pointer :: maxLevelEdgeTop + + integer :: timeLevel + + call mpas_timer_start("ocn_filter_btr_mode_tend_vel") + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_array(tendPool, 'normalVelocity', tend_normalVelocity) + + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + do iEdge = 1, nEdges + + ! thicknessSum is initialized outside the loop because on land boundaries + ! maxLevelEdgeTop=0, but I want to initialize thicknessSum with a + ! nonzero value to avoid a NaN. + normalThicknessFluxSum = layerThicknessEdge(1,iEdge) * tend_normalVelocity(1,iEdge) + thicknessSum = layerThicknessEdge(1,iEdge) + + do k = 2, maxLevelEdgeTop(iEdge) + normalThicknessFluxSum = normalThicknessFluxSum + layerThicknessEdge(k,iEdge) * tend_normalVelocity(k,iEdge) + thicknessSum = thicknessSum + layerThicknessEdge(k,iEdge) + enddo + + vertSum = normalThicknessFluxSum / thicknessSum + do k = 1, maxLevelEdgeTop(iEdge) + tend_normalVelocity(k,iEdge) = tend_normalVelocity(k,iEdge) - vertSum + enddo + enddo ! iEdge + + call mpas_timer_stop("ocn_filter_btr_mode_tend_vel") + + end subroutine ocn_filter_btr_mode_tend_vel!}}} + +!*********************************************************************** +! +! routine ocn_diagnostics_init +! +!> \brief Initializes flags used within diagnostics routines. +!> \author Mark Petersen +!> \date 4 November 2011 +!> \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 + + logical, pointer :: config_include_KE_vertex + character (len=StrKIND), pointer :: config_time_integrator + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_include_KE_vertex', config_include_KE_vertex) + call mpas_pool_get_config(ocnConfigs, 'config_time_integrator', config_time_integrator) + + 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 includes f: 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 the Coriolis term + ! is added separately to the momentum tendencies. + fCoef = 0 + end if + + end subroutine ocn_diagnostics_init!}}} + +!*********************************************************************** +! +! routine computeKPPInputFields +! +!> \brief +!> Compute fields necessary to drive the CVMix KPP module +!> \author Todd Ringler +!> \date 20 August 2013 +!> \details +!> CVMix/KPP requires the following fields as intent(in): +!> surfaceBuoyancyForcing +!> surfaceFrictionVelocity +!> bulkRichardsonNumberBuoy +!> bulkRichardsonNumberShear +!> +! +!----------------------------------------------------------------------- + + subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevelIn)!{{{ + + type (mpas_pool_type), intent(in) :: statePool !< Input/Output: State information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(inout) :: diagnosticsPool !< Diagnostics information derived from State + type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables + integer, intent(in), optional :: timeLevelIn + + ! scalars + integer, pointer :: nCells, nVertLevels + + ! integer pointers + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell + + ! real pointers + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell + real (kind=RKIND), dimension(:), pointer :: penetrativeTemperatureFlux, surfaceMassFlux, & + surfaceBuoyancyForcing, surfaceFrictionVelocity, boundaryLayerDepth, penetrativeTemperatureFluxOBL, & + normalVelocitySurfaceLayer + real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, surfaceWindStressMagnitude + real (kind=RKIND), dimension(:,:), pointer :: & + layerThickness, zMid, zTop, tracersSurfaceValues, densitySurfaceDisplaced, density, & + normalVelocity, surfaceTracerFlux, thermalExpansionCoeff, salineContractionCoeff + + real (kind=RKIND), dimension(:), pointer :: & + indexSurfaceLayerDepth + + real (kind=RKIND), dimension(:,:), pointer :: & + bulkRichardsonNumberBuoy, bulkRichardsonNumberShear + + ! local + integer :: iCell, iEdge, i, k, err, timeLevel + integer, pointer :: indexTempFlux, indexSaltFlux + real (kind=RKIND) :: numerator, denominator, turbulentVelocitySquared + real (kind=RKIND) :: buoyContribution, shearContribution, factor, deltaVelocitySquared, delU2, invAreaCell + real (kind=RKIND), dimension(:), allocatable :: buoySmoothed, shearSmoothed + + type (field2DReal), pointer :: densitySurfaceDisplacedField, thermalExpansionCoeffField, salineContractionCoeffField + real (kind=RKIND), pointer :: config_density0 + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + + ! set the parameter turbulentVelocitySquared + turbulentVelocitySquared = 0.001 + + ! set scalar values + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(forcingPool, 'index_surfaceTemperatureFlux', indexTempFlux) + call mpas_pool_get_dimension(forcingPool, 'index_surfaceSalinityFlux', indexSaltFlux) + + ! set pointers into state, mesh, diagnostics and scratch + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'tracersSurfaceValue ', tracersSurfaceValues) + call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) + call mpas_pool_get_array(diagnosticsPool, 'surfaceFrictionVelocity', surfaceFrictionVelocity) + call mpas_pool_get_array(diagnosticsPool, 'penetrativeTemperatureFluxOBL', penetrativeTemperatureFluxOBL) + call mpas_pool_get_array(diagnosticsPool, 'bulkRichardsonNumberBuoy', bulkRichardsonNumberBuoy) + call mpas_pool_get_array(diagnosticsPool, 'bulkRichardsonNumberShear', bulkRichardsonNumberShear) + call mpas_pool_get_array(diagnosticsPool, 'indexSurfaceLayerDepth', indexSurfaceLayerDepth) + call mpas_pool_get_array(diagnosticsPool, 'surfaceBuoyancyForcing', surfaceBuoyancyForcing) + call mpas_pool_get_array(diagnosticsPool, 'normalVelocitySurfaceLayer', normalVelocitySurfaceLayer) + + call mpas_pool_get_array(forcingPool, 'surfaceMassFlux', surfaceMassFlux) + call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) + call mpas_pool_get_array(forcingPool, 'penetrativeTemperatureFlux', penetrativeTemperatureFlux) + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + call mpas_pool_get_array(forcingPool, 'surfaceWindStressMagnitude', surfaceWindStressMagnitude) + + ! allocate scratch space displaced density computation + call mpas_pool_get_field(scratchPool, 'densitySurfaceDisplaced', densitySurfaceDisplacedField) + call mpas_pool_get_field(scratchPool, 'thermalExpansionCoeff', thermalExpansionCoeffField) + call mpas_pool_get_field(scratchPool, 'salineContractionCoeff', salineContractionCoeffField) + call mpas_allocate_scratch_field(densitySurfaceDisplacedField, .true.) + call mpas_allocate_scratch_field(thermalExpansionCoeffField, .true.) + call mpas_allocate_scratch_field(salineContractionCoeffField, .true.) + densitySurfaceDisplaced => densitySurfaceDisplacedField % array + thermalExpansionCoeff => thermalExpansionCoeffField % array + salineContractionCoeff => salineContractionCoeffField % array + + ! allocate local work space + allocate(buoySmoothed(nVertLevels)) + allocate(shearSmoothed(nVertLevels)) + + ! compute EOS by displacing SST/SSS to every vertical layer in column + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 0, 'surfaceDisplaced', densitySurfaceDisplaced, err, & + thermalExpansionCoeff, salineContractionCoeff, timeLevel) + + do iCell = 1, nCells + invAreaCell = 1.0 / areaCell(iCell) + + ! compute surface buoyancy forcing based on surface fluxes of mass, temperature, salinity and frazil (frazil to be added later) + ! since this computation is confusing, variables, units and sign convention is repeated here + ! everything below should be consistent with that specified in Registry + ! everything below should be consistent with the CVMix/KPP documentation: https://www.dropbox.com/s/6hqgc0rsoa828nf/cvmix_20aug2013.pdf + ! + ! surfaceMassFlux: surface mass flux, m/s, positive into ocean + ! surfaceTracerFlux(indexTempFlux): non-penetrative temperature flux, C m/s, positive into ocean + ! penetrativeTemperatureFlux: penetrative surface temperature flux at ocean surface, positive into ocean + ! surfaceTracerFlux(indexSaltFlux): salinity flux, PSU m/s, positive into ocean + ! penetrativeTemperatureFluxOBL: penetrative temperature flux computed at z=OBL, positive down + ! + ! note: the following fields used the CVMix/KPP computation of buoyancy forcing are not included here + ! 1. Tm: temperature associated with surfaceMassFlux, C (here we assume Tm == temperatureSurfaceValue) + ! 2. Sm: salinity associated with surfaceMassFlux, PSU (here we assume Sm == salinitySurfaceValue and account for salinity flux in surfaceTracerFlux array) + ! + surfaceBuoyancyForcing(iCell) = thermalExpansionCoeff (1,iCell) * & + (surfaceTracerFlux(indexTempFlux,iCell) + penetrativeTemperatureFlux(iCell) - penetrativeTemperatureFluxOBL(iCell)) & + - salineContractionCoeff(1,iCell) * surfaceTracerFlux(indexSaltFlux,iCell) + + ! at this point, surfaceBuoyancyForcing has units of m/s + ! change into units of m^2/s^3 (which can be thought of as the flux of buoyancy, units of buoyancy * velocity ) + surfaceBuoyancyForcing(iCell) = surfaceBuoyancyForcing(iCell) * gravity + + ! compute magnitude of surface windstress + deltaVelocitySquared = 0.0 + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + factor = 0.5 * dcEdge(iEdge) * dvEdge(iEdge) * invAreaCell + delU2 = (surfaceWindStress(iEdge))**2 + deltaVelocitySquared = deltaVelocitySquared + factor * delU2 + enddo + surfacewindStressMagnitude(iCell) = sqrt(deltaVelocitySquared) + + ! compute surface friction velocity + surfaceFrictionVelocity(iCell) = sqrt(surfacewindStressMagnitude(iCell) / config_density0) + + ! zero the bulk Richardson number within the ocean surface layer + ! this prevent CVMix/KPP from mis-diagnosing the OBL to be within the surface layer + bulkRichardsonNumberBuoy (:,iCell) = 1.0e8 + bulkRichardsonNumberShear(:,iCell) = 1.0 + + ! loop over vertical to compute bulk Richardson number + do k=1,maxLevelCell(iCell) + + ! find deltaVelocitySquared defined at cell centers based on velocity at levels 1 and k + deltaVelocitySquared = 0.0 + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + factor = 0.5 * dcEdge(iEdge) * dvEdge(iEdge) * invAreaCell + delU2 = (normalVelocitySurfaceLayer(iEdge) - normalVelocity(k,iEdge))**2 + deltaVelocitySquared = deltaVelocitySquared + factor * delU2 + enddo + + buoyContribution = gravity * (density(k,iCell) - densitySurfaceDisplaced(k,iCell)) / config_density0 + shearContribution = max(deltaVelocitySquared,1.0e-10) + + ! compute bulk Richardson number + ! we estimate the bulk Richardson number here, but its value will be updated + ! in the ocn_vmix_coefs_cvmix_build when we have access to the turbulent velocity scale and unresolved shear + bulkRichardsonNumberBuoy(k,iCell) = buoyContribution + bulkRichardsonNumberShear(k,iCell) = shearContribution + + enddo + + ! remove 2dz mode from bulkRichardsonNumber{Buoy,Shear} + buoySmoothed(:) = 0.0 + shearSmoothed(:) = 0.0 + do k=2,maxLevelCell(iCell)-1 + buoySmoothed(k) = (bulkRichardsonNumberBuoy(k-1,iCell) + 2*bulkRichardsonNumberBuoy(k,iCell) + bulkRichardsonNumberBuoy(k+1,iCell)) / 4.0 + shearSmoothed(k) = (bulkRichardsonNumberShear(k-1,iCell) + 2*bulkRichardsonNumberShear(k,iCell) + bulkRichardsonNumberShear(k+1,iCell)) / 4.0 + enddo + buoySmoothed(1) = buoySmoothed(2) + shearSmoothed(1) = shearSmoothed(2) + buoySmoothed(maxLevelCell(iCell))=buoySmoothed(maxLevelCell(iCell)-1) + shearSmoothed(maxLevelCell(iCell))=shearSmoothed(maxLevelCell(iCell)-1) + + bulkRichardsonNumberBuoy(1:maxLevelCell(iCell),iCell) = buoySmoothed(1:maxLevelCell(iCell)) + bulkRichardsonNumberShear(1:maxLevelCell(iCell),iCell) = shearSmoothed(1:maxLevelCell(iCell)) + + ! bulkRichardsonNumberBuoy to a negative value within surface layer to prevent CVMix/KPP from + ! incorrectly diagnosing OBL to be within surface layer + bulkRichardsonNumberBuoy(1:int(indexSurfaceLayerDepth(iCell)),iCell) = -1.0 + + enddo + + ! deallocate scratch space + call mpas_deallocate_scratch_field(densitySurfaceDisplacedField, .true.) + call mpas_deallocate_scratch_field(thermalExpansionCoeffField, .true.) + call mpas_deallocate_scratch_field(salineContractionCoeffField, .true.) + + ! deallocate local work space + deallocate(buoySmoothed) + deallocate(shearSmoothed) + + end subroutine computeKPPInputFields!}}} + +!*********************************************************************** +! +! routine ocn_reconstruct_gm_vectors +! +!> \brief Computes cell-centered vector diagnostics +!> \author Mark Petersen +!> \date May 2014 +!> \details +!> This routine computes cell-centered vector diagnostics +! +!----------------------------------------------------------------------- + + subroutine ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) + + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostic information + + real (kind=RKIND), dimension(:,:), pointer :: & + normalTransportVelocity, transportVelocityX, transportVelocityY, transportVelocityZ, transportVelocityZonal, transportVelocityMeridional, & + normalGMBolusVelocity, GMBolusVelocityX, GMBolusVelocityY, GMBolusVelocityZ, GMBolusVelocityZonal, GMBolusVelocityMeridional, & + relativeSlopeTopOfEdge, relativeSlopeTopOfCellX, relativeSlopeTopOfCellY, relativeSlopeTopOfCellZ, relativeSlopeTopOfCellZonal, relativeSlopeTopOfCellMeridional, & + gmStreamFuncTopOfEdge, GMStreamFuncX, GMStreamFuncY, GMStreamFuncZ, GMStreamFuncZonal, GMStreamFuncMeridional + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'transportVelocityX', transportVelocityX) + call mpas_pool_get_array(diagnosticsPool, 'transportVelocityY', transportVelocityY) + call mpas_pool_get_array(diagnosticsPool, 'transportVelocityZ', transportVelocityZ) + call mpas_pool_get_array(diagnosticsPool, 'transportVelocityZonal', transportVelocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'transportVelocityMeridional', transportVelocityMeridional) + + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityX', GMBolusVelocityX) + call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityY', GMBolusVelocityY) + call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityZ', GMBolusVelocityZ) + call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityZonal', GMBolusVelocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityMeridional', GMBolusVelocityMeridional) + + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfEdge', relativeSlopeTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfCellX', relativeSlopeTopOfCellX) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfCellY', relativeSlopeTopOfCellY) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfCellZ', relativeSlopeTopOfCellZ) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfCellZonal', relativeSlopeTopOfCellZonal) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfCellMeridional', relativeSlopeTopOfCellMeridional) + + call mpas_pool_get_array(diagnosticsPool, 'gmStreamFuncTopOfEdge', gmStreamFuncTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'GMStreamFuncX', GMStreamFuncX) + call mpas_pool_get_array(diagnosticsPool, 'GMStreamFuncY', GMStreamFuncY) + call mpas_pool_get_array(diagnosticsPool, 'GMStreamFuncZ', GMStreamFuncZ) + call mpas_pool_get_array(diagnosticsPool, 'GMStreamFuncZonal', GMStreamFuncZonal) + call mpas_pool_get_array(diagnosticsPool, 'GMStreamFuncMeridional', GMStreamFuncMeridional) + + call mpas_reconstruct(meshPool, normalTransportVelocity, & + transportVelocityX, & + transportVelocityY, & + transportVelocityZ, & + transportVelocityZonal, & + transportVelocityMeridional & + ) + + call mpas_reconstruct(meshPool, normalGMBolusVelocity, & + GMBolusVelocityX, & + GMBolusVelocityY, & + GMBolusVelocityZ, & + GMBolusVelocityZonal, & + GMBolusVelocityMeridional & + ) + + call mpas_reconstruct(meshPool, relativeSlopeTopOfEdge, & + relativeSlopeTopOfCellX, & + relativeSlopeTopOfCellY, & + relativeSlopeTopOfCellZ, & + relativeSlopeTopOfCellZonal, & + relativeSlopeTopOfCellMeridional & + ) + + call mpas_reconstruct(meshPool, gmStreamFuncTopOfEdge, & + GMStreamFuncX, & + GMStreamFuncY, & + GMStreamFuncZ, & + GMStreamFuncZonal, & + GMStreamFuncMeridional & + ) + + end subroutine ocn_reconstruct_gm_vectors!}}} + +!*********************************************************************** + +end module ocn_diagnostics + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics_routines.F b/src/core_ocean/shared/mpas_ocn_diagnostics_routines.F new file mode 100644 index 0000000000..dcb80ba7ff --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_diagnostics_routines.F @@ -0,0 +1,147 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_diagnostics_routines +! +!> \brief MPAS ocean diagnostics driver +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This module contains the routines for computing individual diagnostic variables +! +!----------------------------------------------------------------------- + +module ocn_diagnostics_routines + + use mpas_grid_types + use mpas_constants + use mpas_timer + + implicit none + private + save + + type (timer_node), pointer :: diagEOSTimer + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_relativeVorticity_circulation + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_relativeVorticity_circulation +! +!> \brief Computes relative vorticity and circulation +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date November 2013 +!> \details +!> Computes relative vorticity and circulation +! +!----------------------------------------------------------------------- + + subroutine ocn_relativeVorticity_circulation(relativeVorticity, circulation, meshPool, normalVelocity, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool + + real (kind=RKIND), dimension(:,:), intent(in) :: & + normalVelocity + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:), intent(out) :: & + relativeVorticity + + real (kind=RKIND), dimension(:,:), intent(out) :: & + circulation + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iVertex, iEdge, i, k + integer, pointer :: nEdges, nVertices, vertexDegree + integer, dimension(:), pointer :: maxLevelVertexBot + integer, dimension(:,:), pointer :: edgesOnVertex, edgeSignOnVertex + + real (kind=RKIND) :: invAreaTri1, r_tmp + real (kind=RKIND), dimension(:), pointer :: & + dcEdge, areaTriangle + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) + call mpas_pool_get_array(meshPool, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(meshPool, 'edgeSignOnVertex', edgeSignOnVertex) + + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + err = 0 + + circulation(:,:) = 0.0 + relativeVorticity(:,:) = 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) * normalVelocity(k, iEdge) + + circulation(k, iVertex) = circulation(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp + relativeVorticity(k, iVertex) = relativeVorticity(k, iVertex) + edgeSignOnVertex(i, iVertex) * r_tmp * invAreaTri1 + end do + end do + end do + + + !-------------------------------------------------------------------- + + end subroutine ocn_relativeVorticity_circulation!}}} + +end module ocn_diagnostics_routines + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_equation_of_state.F b/src/core_ocean/shared/mpas_ocn_equation_of_state.F similarity index 79% rename from src/core_ocean/mpas_ocn_equation_of_state.F rename to src/core_ocean/shared/mpas_ocn_equation_of_state.F index 4f38c99dba..78fcb3cf83 100644 --- a/src/core_ocean/mpas_ocn_equation_of_state.F +++ b/src/core_ocean/shared/mpas_ocn_equation_of_state.F @@ -22,9 +22,9 @@ module ocn_equation_of_state use mpas_kind_types use mpas_grid_types - use mpas_configure use ocn_equation_of_state_linear use ocn_equation_of_state_jm + use ocn_constants use mpas_io_units implicit none @@ -71,8 +71,8 @@ module ocn_equation_of_state ! !----------------------------------------------------------------------- - subroutine ocn_equation_of_state_density(state, diagnostics, mesh, k_displaced, displacement_type, density, err, & - thermalExpansionCoeff, salineContractionCoeff)!{{{ + subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, k_displaced, displacement_type, density, err, & + thermalExpansionCoeff, salineContractionCoeff, timeLevelIn)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This module contains routines necessary for computing the density ! from model temperature and salinity using an equation of state. @@ -92,9 +92,10 @@ subroutine ocn_equation_of_state_density(state, diagnostics, mesh, k_displaced, !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - type (state_type), intent(inout) :: state - type (diagnostics_type), intent(inout) :: diagnostics - type (mesh_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: statePool + type (mpas_pool_type), intent(inout) :: diagnosticsPool + type (mpas_pool_type), intent(in) :: meshPool + integer, intent(in), optional :: timeLevelIn integer :: k_displaced character(len=*), intent(in) :: displacement_type real (kind=RKIND), dimension(:,:), intent(out) :: density @@ -106,24 +107,32 @@ subroutine ocn_equation_of_state_density(state, diagnostics, mesh, k_displaced, integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:,:), pointer :: tracersSurfaceValue real (kind=RKIND), dimension(:,:,:), pointer :: tracers - integer :: nCells, iCell, k, indexT, indexS + integer :: iCell, k + integer, pointer :: indexT, indexS type (dm_info) :: dminfo + integer :: timeLevel err = 0 - tracersSurfaceValue => diagnostics % tracersSurfaceValue % array - tracers => state % tracers % array - indexT = state % index_temperature - indexS = state % index_salinity + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_array(diagnosticsPool, 'tracersSurfaceValue', tracersSurfaceValue) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_dimension(statePool, 'index_temperature', indexT) + call mpas_pool_get_dimension(statePool, 'index_salinity', indexS) if (linearEos) then - call ocn_equation_of_state_linear_density(mesh, indexT, indexS, tracers, density, err, & + call ocn_equation_of_state_linear_density(meshPool, indexT, indexS, tracers, density, err, & thermalExpansionCoeff, salineContractionCoeff) elseif (jmEos) then - call ocn_equation_of_state_jm_density(mesh, k_displaced, displacement_type, indexT, indexS, tracers, density, err, & + call ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_type, indexT, indexS, tracers, density, err, & tracersSurfaceValue, thermalExpansionCoeff, salineContractionCoeff) endif @@ -157,14 +166,21 @@ subroutine ocn_equation_of_state_init(err)!{{{ integer, intent(out) :: err + character (len=StrKIND), pointer :: config_eos_type + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_eos_type', config_eos_type) + linearEos = .false. jmEos = .false. if (config_eos_type.eq.'linear') then linearEos = .true. + call ocn_equation_of_state_linear_init(err) elseif (config_eos_type.eq.'jm') then jmEos = .true. + call ocn_equation_of_state_jm_init(err) else write (stderrUnit,*) 'Invalid choice for config_eos_type.' write (stderrUnit,*) ' Choices are: linear, jm' diff --git a/src/core_ocean/mpas_ocn_equation_of_state_jm.F b/src/core_ocean/shared/mpas_ocn_equation_of_state_jm.F similarity index 94% rename from src/core_ocean/mpas_ocn_equation_of_state_jm.F rename to src/core_ocean/shared/mpas_ocn_equation_of_state_jm.F index 09957deca5..348fc5562b 100644 --- a/src/core_ocean/mpas_ocn_equation_of_state_jm.F +++ b/src/core_ocean/shared/mpas_ocn_equation_of_state_jm.F @@ -22,9 +22,9 @@ module ocn_equation_of_state_jm use mpas_kind_types use mpas_grid_types - use mpas_configure use mpas_dmpar use mpas_io_units + use ocn_constants implicit none private @@ -75,13 +75,13 @@ module ocn_equation_of_state_jm !> can be computed using displacement_type = 'surfaceDisplaced'. !> !> When using displacement_type = 'surfaceDisplaced', k_displaced is -!> ignored and tracersSurfaceValue must be present. +!> ignored and tracersSurfaceLayerValue must be present. ! !----------------------------------------------------------------------- - subroutine ocn_equation_of_state_jm_density(mesh, k_displaced, displacement_type, & + subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_type, & indexT, indexS, tracers, density, err, & - tracersSurfaceValue, thermalExpansionCoeff, salineContractionCoeff)!{{{ + tracersSurfaceLayerValue, thermalExpansionCoeff, salineContractionCoeff)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This module contains routines necessary for computing the density ! from model temperature and salinity using an equation of state. @@ -94,7 +94,7 @@ subroutine ocn_equation_of_state_jm_density(mesh, k_displaced, displacement_type ! s - state: tracers ! k_displaced - ! If k_displaced<=0, density is returned with no displaced + ! If k_displaced=0, density is returned with no displacement ! If k_displaced>0,the density returned is that for a parcel ! adiabatically displaced from its original level to level ! k_displaced. @@ -105,19 +105,20 @@ subroutine ocn_equation_of_state_jm_density(mesh, k_displaced, displacement_type implicit none - type (mesh_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: meshPool integer, intent(in) :: k_displaced, indexT, indexS character(len=*), intent(in) :: displacement_type real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers real (kind=RKIND), dimension(:,:), intent(out) :: density integer, intent(out) :: err - real (kind=RKIND), dimension(:,:), intent(in), optional :: tracersSurfaceValue + real (kind=RKIND), dimension(:,:), intent(in), optional :: tracersSurfaceLayerValue real (kind=RKIND), dimension(:,:), intent(out), optional :: & thermalExpansionCoeff, &! Thermal expansion coefficient (alpha), defined as $-1/\rho d\rho/dT$ (note negative sign) salineContractionCoeff ! Saline contraction coefficient (beta), defined as $1/\rho d\rho/dS$ type (dm_info) :: dminfo - integer :: iEdge, iCell, iVertex, k, nCells, nEdges, nVertices, nVertLevels, k_displaced_local + integer :: iEdge, iCell, iVertex, k, k_displaced_local + integer, pointer :: nCells, nEdges, nVertices, nVertLevels integer, dimension(:), pointer :: maxLevelCell character(len=60) :: displacement_type_local @@ -217,25 +218,26 @@ subroutine ocn_equation_of_state_jm_density(mesh, k_displaced, displacement_type err = 0 - nCells = mesh % nCells - maxLevelCell => mesh % maxLevelCell % array - nVertLevels = mesh % nVertLevels - refBottomDepth => mesh % refBottomDepth % array + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) ! allocate local T,S tracer field allocate(tracerTS(2,nVertLevels,nCells+1)) ! fill tracerTS if (displacement_type == 'surfaceDisplaced') then - if(present(tracersSurfaceValue)) then + if(present(tracersSurfaceLayerValue)) then do k=1,nVertLevels - tracerTS(1,k,:) = tracersSurfaceValue(indexT,:) - tracerTS(2,k,:) = tracersSurfaceValue(indexS,:) + tracerTS(1,k,:) = tracersSurfaceLayerValue(indexT,:) + tracerTS(2,k,:) = tracersSurfaceLayerValue(indexS,:) enddo displacement_type_local = 'relative' k_displaced_local = 0 else - write (stderrUnit,*) 'Abort: tracersSurfaceValue must be present' + write (stderrUnit,*) 'Abort: tracersSurfaceLayerValue must be present' call mpas_dmpar_abort(dminfo) endif else @@ -430,7 +432,6 @@ subroutine ocn_equation_of_state_jm_init(err)!{{{ ! call individual init routines for each parameterization ! !----------------------------------------------------------------- - integer, intent(out) :: err err = 0 diff --git a/src/core_ocean/mpas_ocn_equation_of_state_linear.F b/src/core_ocean/shared/mpas_ocn_equation_of_state_linear.F similarity index 78% rename from src/core_ocean/mpas_ocn_equation_of_state_linear.F rename to src/core_ocean/shared/mpas_ocn_equation_of_state_linear.F index beca01f26f..c03c9b9f77 100644 --- a/src/core_ocean/mpas_ocn_equation_of_state_linear.F +++ b/src/core_ocean/shared/mpas_ocn_equation_of_state_linear.F @@ -21,7 +21,7 @@ module ocn_equation_of_state_linear use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -47,6 +47,13 @@ module ocn_equation_of_state_linear ! Private module variables ! !-------------------------------------------------------------------- + real (kind=RKIND), pointer :: config_eos_linear_densityref + real (kind=RKIND), pointer :: config_eos_linear_alpha + real (kind=RKIND), pointer :: config_eos_linear_beta + real (kind=RKIND), pointer :: config_eos_linear_Tref + real (kind=RKIND), pointer :: config_eos_linear_Sref + + !*********************************************************************** @@ -64,7 +71,7 @@ module ocn_equation_of_state_linear ! !----------------------------------------------------------------------- - subroutine ocn_equation_of_state_linear_density(mesh, indexT, indexS, tracers, density, err, & + subroutine ocn_equation_of_state_linear_density(meshPool, indexT, indexS, tracers, density, err, & thermalExpansionCoeff, salineContractionCoeff)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This module contains routines necessary for computing the density @@ -82,7 +89,7 @@ subroutine ocn_equation_of_state_linear_density(mesh, indexT, indexS, tracers, d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - type (mesh_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: meshPool integer, intent(in) :: indexT, indexS real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers real (kind=RKIND), dimension(:,:), intent(inout) :: density @@ -92,35 +99,36 @@ subroutine ocn_equation_of_state_linear_density(mesh, indexT, indexS, tracers, d salineContractionCoeff ! Saline contraction coefficient (beta), defined as $1/\rho d\rho/dS$ integer, dimension(:), pointer :: maxLevelCell - integer :: nCells, iCell, k + integer :: iCell, k + integer, pointer :: nCells type (dm_info) :: dminfo - maxLevelCell => mesh % maxLevelCell % array - nCells = mesh % nCells + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) err = 0 - do iCell=1,nCells - do k=1,maxLevelCell(iCell) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) ! Linear equation of state density(k,iCell) = config_eos_linear_densityref & - - config_eos_linear_alpha * (tracers(indexT,k,iCell)-config_eos_linear_Tref) & - + config_eos_linear_beta * (tracers(indexS,k,iCell)-config_eos_linear_Sref) + - 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 if (present(thermalExpansionCoeff)) then - do iCell=1,nCells - do k=1,maxLevelCell(iCell) - thermalExpansionCoeff(k,iCell) = config_eos_linear_alpha/density(k,iCell) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + thermalExpansionCoeff(k,iCell) = config_eos_linear_alpha / density(k,iCell) end do end do endif if (present(salineContractionCoeff)) then - do iCell=1,nCells - do k=1,maxLevelCell(iCell) - salineContractionCoeff(k,iCell) = config_eos_linear_beta/density(k,iCell) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + salineContractionCoeff(k,iCell) = config_eos_linear_beta / density(k,iCell) end do end do endif @@ -158,6 +166,12 @@ subroutine ocn_equation_of_state_linear_init(err)!{{{ err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_eos_linear_densityref', config_eos_linear_densityref) + call mpas_pool_get_config(ocnConfigs, 'config_eos_linear_alpha', config_eos_linear_alpha) + call mpas_pool_get_config(ocnConfigs, 'config_eos_linear_beta', config_eos_linear_beta) + call mpas_pool_get_config(ocnConfigs, 'config_eos_linear_Tref', config_eos_linear_Tref) + call mpas_pool_get_config(ocnConfigs, 'config_eos_linear_Sref', config_eos_linear_Sref) + !-------------------------------------------------------------------- end subroutine ocn_equation_of_state_linear_init!}}} diff --git a/src/core_ocean/mpas_ocn_forcing.F b/src/core_ocean/shared/mpas_ocn_forcing.F similarity index 67% rename from src/core_ocean/mpas_ocn_forcing.F rename to src/core_ocean/shared/mpas_ocn_forcing.F index e4055e38fb..90996f2fbc 100644 --- a/src/core_ocean/mpas_ocn_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_forcing.F @@ -12,7 +12,6 @@ !> \brief MPAS ocean forcing !> \author Doug Jacobsen !> \date 04/25/12 -!> \version SVN:$Id:$ !> \details !> This module contains driver routines for building the forcing arrays. ! @@ -22,12 +21,12 @@ module ocn_forcing use mpas_kind_types use mpas_grid_types - use mpas_configure use mpas_timekeeping use mpas_io_units use mpas_dmpar use ocn_forcing_bulk use ocn_forcing_restoring + use ocn_constants implicit none private @@ -71,13 +70,12 @@ module ocn_forcing !> \brief Determines the forcing arrays. !> \author Doug Jacobsen !> \date 12/13/12 -!> \version SVN:$Id$ !> \details !> This routine computes the forcing arrays used later in MPAS. ! !----------------------------------------------------------------------- - subroutine ocn_forcing_build_arrays(mesh, state, forcing, err)!{{{ + subroutine ocn_forcing_build_arrays(meshPool, statePool, forcingPool, err, timeLevelIn)!{{{ !----------------------------------------------------------------- ! @@ -85,11 +83,11 @@ subroutine ocn_forcing_build_arrays(mesh, state, forcing, err)!{{{ ! !----------------------------------------------------------------- - type (state_type), intent(in) :: & - state !< Input: State information + type (mpas_pool_type), intent(in) :: & + statePool, & !< Input: State information + meshPool !< Input: mesh information - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + integer, intent(in), optional :: timeLevelIn !----------------------------------------------------------------- ! @@ -97,7 +95,7 @@ subroutine ocn_forcing_build_arrays(mesh, state, forcing, err)!{{{ ! !----------------------------------------------------------------- - type (forcing_type), intent(inout) :: forcing !< Input: Forcing information + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information !----------------------------------------------------------------- ! @@ -113,15 +111,42 @@ subroutine ocn_forcing_build_arrays(mesh, state, forcing, err)!{{{ ! !----------------------------------------------------------------- + integer :: timeLevel + integer, pointer :: indexTemperature, indexSalinity + integer, pointer :: indexSurfaceTemperatureFlux, indexSurfaceSalinityFlux + + real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore + real (kind=RKIND), dimension(:,:), pointer :: surfaceTracerFlux + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + if ( bulkOn ) then - call ocn_forcing_bulk_build_arrays(mesh, forcing, err) + call ocn_forcing_bulk_build_arrays(meshPool, forcingPool, err) end if if ( restoringOn ) then - call ocn_forcing_restoring_build_arrays(mesh, state % index_temperature, state % index_salinity, & - forcing % index_surfaceTemperatureFlux, forcing % index_surfaceSalinityFlux, & - state % tracers % array, mesh % temperatureRestore % array, mesh % salinityRestore % array, & - forcing % surfaceTracerFlux % array, err) + call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + + call mpas_pool_get_dimension(forcingPool, 'index_surfaceTemperatureFlux', indexSurfaceTemperatureFlux) + call mpas_pool_get_dimension(forcingPool, 'index_surfaceSalinityFlux', indexSurfaceSalinityFlux) + + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + + call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) + call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) + + call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) + + call ocn_forcing_restoring_build_arrays(meshPool, indexTemperature, indexSalinity, & + indexSurfaceTemperatureFlux, indexSurfaceSalinityFlux, & + tracers, temperatureRestore, salinityRestore, & + surfaceTracerFlux, err) end if !-------------------------------------------------------------------- @@ -135,7 +160,6 @@ end subroutine ocn_forcing_build_arrays!}}} !> \brief Initializes forcing module !> \author Doug Jacobsen !> \date 12/13/12 -!> \version SVN:$Id$ !> \details !> This routine initializes the forcing modules. ! @@ -147,9 +171,15 @@ subroutine ocn_forcing_init(err)!{{{ integer :: err1 + character (len=StrKIND), pointer :: config_forcing_type + real (kind=RKIND), pointer :: config_flux_attenuation_coefficient + err = 0 err1 = 0 + call mpas_pool_get_config(ocnConfigs, 'config_flux_attenuation_coefficient', config_flux_attenuation_coefficient) + call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) + attenuationCoefficient = config_flux_attenuation_coefficient if ( config_forcing_type == trim('bulk') ) then @@ -180,18 +210,18 @@ end subroutine ocn_forcing_init!}}} !> \brief Transmission coefficient array for surface forcing. !> \author Doug Jacobsen !> \date 10/03/2013 -!> \version SVN:$Id$ !> \details !> This subroutine builds the transmission coefficient array for use in !> applying surface fluxes deeper than the surface layer. ! !----------------------------------------------------------------------- - subroutine ocn_forcing_build_transmission_array(mesh, state, forcing, err)!{{{ - type (mesh_type), intent(in) :: mesh !< Input: Mesh information - type (state_type), intent(in) :: state !< Input: State information - type (forcing_type), intent(inout) :: forcing !< Input/Output: Forcing information + subroutine ocn_forcing_build_transmission_array(meshPool, statePool, forcingPool, err, timeLevelIn)!{{{ + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(inout) :: forcingPool !< Input/Output: Forcing information integer, intent(out) :: err !< Output: Error code + integer, intent(in), optional :: timeLevelIn !************************************************ ! @@ -203,20 +233,26 @@ subroutine ocn_forcing_build_transmission_array(mesh, state, forcing, err)!{{{ real (kind=RKIND), dimension(:,:), pointer :: layerThickness, transmissionCoefficients - integer :: iCell, k - integer :: nCells + integer :: iCell, k, timeLevel + integer, pointer :: nCells integer, dimension(:), pointer :: maxLevelCell err = 0 - nCells = mesh % nCells + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - maxLevelCell => mesh % maxLevelCell % array + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - layerThickness => state % layerThickness % array + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) - transmissionCoefficients => forcing % transmissionCoefficients % array + call mpas_pool_get_array(forcingPool, 'transmissionCoefficients', transmissionCoefficients) do iCell = 1, nCells zTop = 0.0_RKIND @@ -241,7 +277,6 @@ end subroutine ocn_forcing_build_transmission_array!}}} !> \brief Transmission coefficient for surface forcing. !> \author Doug Jacobsen !> \date 05/03/2013 -!> \version SVN:$Id$ !> \details !> This function computes and returns the transmission coefficient for surface !> forcing based on depth. It uses an exponential decay function to determine the @@ -252,8 +287,7 @@ end subroutine ocn_forcing_build_transmission_array!}}} real (kind=RKIND) function ocn_forcing_transmission(z)!{{{ real (kind=RKIND), intent(in) :: z - - ocn_forcing_transmission = exp(z/attenuationCoefficient) + ocn_forcing_transmission = exp( z / attenuationCoefficient ) end function ocn_forcing_transmission!}}} diff --git a/src/core_ocean/mpas_ocn_forcing_bulk.F b/src/core_ocean/shared/mpas_ocn_forcing_bulk.F similarity index 68% rename from src/core_ocean/mpas_ocn_forcing_bulk.F rename to src/core_ocean/shared/mpas_ocn_forcing_bulk.F index 2c72f720c5..1b0113f861 100644 --- a/src/core_ocean/mpas_ocn_forcing_bulk.F +++ b/src/core_ocean/shared/mpas_ocn_forcing_bulk.F @@ -12,7 +12,6 @@ !> \brief MPAS ocean bulk forcing !> \author Doug Jacobsen !> \date 04/25/12 -!> \version SVN:$Id:$ !> \details !> This module contains routines for building the forcing arrays, !> if bulk forcing is used. @@ -23,7 +22,6 @@ module ocn_forcing_bulk use mpas_kind_types use mpas_grid_types - use mpas_configure use mpas_timekeeping use ocn_constants @@ -58,35 +56,31 @@ module ocn_forcing_bulk !*********************************************************************** ! -! routine ocn_build_forcing_arrays +! routine ocn_forcing_bulk_build_arrays ! !> \brief Determines the forcing array used for the bulk forcing. !> \author Doug Jacobsen !> \date 04/25/12 -!> \version SVN:$Id$ !> \details !> This routine computes the forcing arrays used later in MPAS. ! !----------------------------------------------------------------------- - subroutine ocn_forcing_bulk_build_arrays(mesh, forcing, err)!{{{ + subroutine ocn_forcing_bulk_build_arrays(meshPool, forcingPool, err)!{{{ !----------------------------------------------------------------- ! ! input variables ! !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - - type (mesh_type), intent(in) :: mesh !< Input: mesh information - - type (forcing_type), intent(inout) :: forcing !< Input: Forcing information - + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information !----------------------------------------------------------------- ! @@ -104,7 +98,8 @@ subroutine ocn_forcing_bulk_build_arrays(mesh, forcing, err)!{{{ integer :: iEdge, cell1, cell2 integer :: iCell, k - integer :: index_temperature_flux, index_salinity_flux + integer, pointer :: index_temperature_flux, index_salinity_flux + integer, pointer :: nCells, nEdges integer, dimension(:,:), pointer :: cellsOnEdge @@ -121,44 +116,46 @@ subroutine ocn_forcing_bulk_build_arrays(mesh, forcing, err)!{{{ real (kind=RKIND), dimension(:), pointer :: surfaceMassFlux, surfaceWindStress, surfaceWindStressMagnitude real (kind=RKIND), dimension(:,:), pointer :: surfaceTracerFlux - angleEdge => mesh % angleEdge % array - cellsOnEdge => mesh % cellsOnEdge % array + err = 0 + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - index_temperature_flux = forcing % index_surfaceTemperatureflux - index_salinity_flux = forcing % index_surfaceSalinityFlux + call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - index_temperature_flux = forcing % index_surfaceTemperatureFlux - index_salinity_flux = forcing % index_surfaceSalinityFlux + call mpas_pool_get_dimension(forcingPool, 'index_surfaceTemperatureFlux', index_temperature_flux) + call mpas_pool_get_dimension(forcingPool, 'index_surfaceSalinityFlux', index_salinity_flux) - surfaceWindStress => forcing % surfaceWindStress % array - surfaceWindStressMagnitude => forcing % surfaceWindStressMagnitude % array - windStressZonal => forcing % windStressZonal % array - windStressMeridional => forcing % windStressMeridional % array - latentHeatFlux => forcing % latentHeatFlux % array - sensibleHeatFlux => forcing % sensibleHeatFlux % array - longWaveHeatFluxUp => forcing % longWaveHeatFluxUp % array - longWaveHeatFluxDown => forcing % longWaveHeatFluxDown % array - evaporationFlux => forcing % evaporationFlux % array - seaIceHeatFlux => forcing % seaIceHeatFlux % array - snowFlux => forcing % snowFlux % array - shortWaveHeatFlux => forcing % shortWaveHeatFlux % array + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + call mpas_pool_get_array(forcingPool, 'surfaceWindStressMagnitude', surfaceWindStressMagnitude) + call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) + call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional) + call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) + call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) + call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxUp', longWaveHeatFluxUp) + call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxDown', longWaveHeatFluxDown) + call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) + call mpas_pool_get_array(forcingPool, 'seaIceHeatFlux', seaIceHeatFlux) + call mpas_pool_get_array(forcingPool, 'snowFlux', snowFlux) + call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) - seaIceFreshWaterFlux => forcing % seaIceFreshWaterFlux % array - seaIceSalinityFlux => forcing % seaIceSalinityFlux % array - riverRunoffFlux => forcing % riverRunoffFlux % array - iceRunoffFlux => forcing % iceRunoffFlux % array + call mpas_pool_get_array(forcingPool, 'seaIceFreshWaterFlux', seaIceFreshWaterFlux) + call mpas_pool_get_array(forcingPool, 'seaIceSalinityFlux', seaIceSalinityFlux) + call mpas_pool_get_array(forcingPool, 'riverRunoffFlux', riverRunoffFlux) + call mpas_pool_get_array(forcingPool, 'iceRunoffFlux', iceRunoffFlux) - rainFlux => forcing % rainFlux % array + call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) - seaSurfacePressure => forcing % seaSurfacePressure % array - iceFraction => forcing % iceFraction % array + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + call mpas_pool_get_array(forcingPool, 'iceFraction', iceFraction) - surfaceMassFlux => forcing % surfaceMassFlux % array - surfaceTracerFlux => forcing % surfaceTracerFlux % array - penetrativeTemperatureFlux => forcing % penetrativeTemperatureFlux % array + call mpas_pool_get_array(forcingPool, 'surfaceMassFlux', surfaceMassFlux) + call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) + call mpas_pool_get_array(forcingPool, 'penetrativeTemperatureFlux', penetrativeTemperatureFlux) ! Convert CESM wind stress to MPAS-O windstress - do iEdge = 1, mesh % nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) @@ -170,7 +167,7 @@ subroutine ocn_forcing_bulk_build_arrays(mesh, forcing, err)!{{{ ! Build surface fluxes at cell centers - do iCell = 1, mesh % nCells + do iCell = 1, nCells surfaceWindStressMagnitude(iCell) = sqrt(windStressZonal(iCell)**2 + windStressMeridional(iCell)**2) surfaceTracerFlux(index_temperature_flux, iCell) = (latentHeatFlux(iCell) + sensibleHeatFlux(iCell) + longWaveHeatFluxUp(iCell) + longWaveHeatFluxDown(iCell) & + seaIceHeatFlux(iCell) - (snowFlux(iCell) + iceRunoffFlux(iCell)) * latent_heat_fusion_mks) * hflux_factor @@ -191,7 +188,6 @@ end subroutine ocn_forcing_bulk_build_arrays!}}} !> \brief Initializes bulk forcing module !> \author Doug Jacobsen !> \date 04/25/12 -!> \version SVN:$Id$ !> \details !> This routine initializes the bulk forcing module. ! diff --git a/src/core_ocean/mpas_ocn_forcing_restoring.F b/src/core_ocean/shared/mpas_ocn_forcing_restoring.F similarity index 83% rename from src/core_ocean/mpas_ocn_forcing_restoring.F rename to src/core_ocean/shared/mpas_ocn_forcing_restoring.F index f5a6d3c077..be673cdc86 100644 --- a/src/core_ocean/mpas_ocn_forcing_restoring.F +++ b/src/core_ocean/shared/mpas_ocn_forcing_restoring.F @@ -20,7 +20,7 @@ module ocn_forcing_restoring use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -67,7 +67,7 @@ module ocn_forcing_restoring ! !----------------------------------------------------------------------- - subroutine ocn_forcing_restoring_build_arrays(mesh, indexT, indexS, indexTFlux, indexSFlux, tracers, temperatureRestoring, salinityRestoring, surfaceTracerFluxes, err)!{{{ + subroutine ocn_forcing_restoring_build_arrays(meshPool, indexT, indexS, indexTFlux, indexSFlux, tracers, temperatureRestoring, salinityRestoring, surfaceTracerFluxes, err)!{{{ !----------------------------------------------------------------- ! @@ -75,8 +75,8 @@ subroutine ocn_forcing_restoring_build_arrays(mesh, indexT, indexS, indexTFlux, ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:,:), intent(in) :: & tracers !< Input: tracer quantities @@ -113,13 +113,14 @@ subroutine ocn_forcing_restoring_build_arrays(mesh, indexT, indexS, indexTFlux, ! !----------------------------------------------------------------- - integer :: iCell, nCellsSolve, k + integer :: iCell, k + integer, pointer :: nCellsSolve real (kind=RKIND) :: invTemp, invSalinity err = 0 - nCellsSolve = mesh % nCellsSolve + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) invTemp = 1.0 / (temperatureTimeScale * 86400.0) invSalinity = 1.0 / (salinityTimeScale * 86400.0) @@ -151,8 +152,16 @@ subroutine ocn_forcing_restoring_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + real (kind=RKIND), pointer :: config_restoreT_timescale, config_restoreT_lengthscale + real (kind=RKIND), pointer :: config_restoreS_timescale, config_restoreS_lengthscale + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_restoreT_timescale', config_restoreT_timescale) + call mpas_pool_get_config(ocnConfigs, 'config_restoreT_lengthscale', config_restoreT_lengthscale) + call mpas_pool_get_config(ocnConfigs, 'config_restoreS_timescale', config_restoreS_timescale) + call mpas_pool_get_config(ocnConfigs, 'config_restoreS_lengthscale', config_restoreS_lengthscale) + temperatureTimeScale = config_restoreT_timescale salinityTimeScale = config_restoreS_timescale temperatureLengthScale = config_restoreT_lengthscale diff --git a/src/core_ocean/mpas_ocn_global_diagnostics.F b/src/core_ocean/shared/mpas_ocn_global_diagnostics.F similarity index 84% rename from src/core_ocean/mpas_ocn_global_diagnostics.F rename to src/core_ocean/shared/mpas_ocn_global_diagnostics.F index d98320434b..69014492a8 100644 --- a/src/core_ocean/mpas_ocn_global_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_global_diagnostics.F @@ -20,10 +20,10 @@ module ocn_global_diagnostics use mpas_grid_types - use mpas_configure use mpas_constants use mpas_dmpar use mpas_timer + use mpas_packages implicit none save @@ -69,25 +69,28 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ type (domain_type), intent(inout) :: domain !< Input/Output: domain information integer, intent(in) :: timeIndex real (kind=RKIND), intent(in) :: dt + integer, intent(in) :: timeLevel type (block_type), pointer :: block type (dm_info), pointer :: dminfo - type (state_type), pointer :: state - type (mesh_type), pointer :: mesh - type (diagnostics_type), pointer :: diagnostics + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: diagnosticsPool - integer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer + integer :: nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins - integer :: timeLevel,k,i, num_tracers, fileID + integer :: k, i, fileID integer :: timeYYYY, timeMM, timeDD, timeH, timeM, timeS + integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, num_tracers character*1 timeChar integer, parameter :: kMaxVariables = 1024 ! this must be a little more than double the number of variables to be reduced integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot - real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal, localCFL, localSum, areaCellGlobal, areaEdgeGlobal, areaTriangleGlobal, time_days + real (kind=RKIND) :: localCFL, localSum, time_days + real (kind=RKIND), pointer :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal, areaCellGlobal, areaEdgeGlobal, areaTriangleGlobal real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, areaTriangle, areaEdge real (kind=RKIND), dimension(:,:), pointer :: layerThickness, normalVelocity, tangentialVelocity, layerThicknessEdge, relativeVorticity, kineticEnergyCell, & - normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, pressure, montgomeryPotential, vertTransportVelocityTop, vertVelocityTop, & + normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, pressure, montgomeryPotential, vertAleTransportTop, vertVelocityTop, & lowFreqDivergence, highFreqThickness, density real (kind=RKIND), dimension(:,:,:), pointer :: tracers @@ -96,6 +99,8 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ real (kind=RKIND), dimension(:,:), allocatable :: enstrophy, normalizedAbsoluteVorticity, workArray + character (len=StrKIND), pointer :: xtime + block => domain % blocklist dminfo => domain % dminfo @@ -110,45 +115,45 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ call mpas_timer_start("diagnostic block loop", .false., diagBlockTimer) do while (associated(block)) - state => block % state % time_levs(timeLevel) % state - mesh => block % mesh - diagnostics => block % diagnostics + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) - num_tracers = state % num_tracers + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) - nVertLevels = mesh % nVertLevels - nCellsSolve = mesh % nCellsSolve - nEdgesSolve = mesh % nEdgesSolve - nVerticesSolve = mesh % nVerticesSolve + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) - areaCell => mesh % areaCell % array - dcEdge => mesh % dcEdge % array - dvEdge => mesh % dvEdge % array - areaTriangle => mesh % areaTriangle % array - maxLevelCell => mesh % maxLevelCell % array - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - maxLevelVertexBot => mesh % maxLevelVertexBot % array + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) allocate(areaEdge(1:nEdgesSolve)) areaEdge = dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve) - layerThickness => state % layerThickness % array - normalVelocity => state % normalVelocity % array - tracers => state % tracers % array - lowFreqDivergence => state % lowFreqDivergence % array - highFreqThickness => state % highFreqThickness % array - - density => diagnostics % density % array - montgomeryPotential => diagnostics % montgomeryPotential % array - pressure => diagnostics % pressure % array - relativeVorticity => diagnostics % relativeVorticity % array - normalizedRelativeVorticityEdge => diagnostics % normalizedRelativeVorticityEdge % array - normalizedPlanetaryVorticityEdge => diagnostics % normalizedPlanetaryVorticityEdge % array - vertTransportVelocityTop => diagnostics % vertTransportVelocityTop % array - vertVelocityTop => diagnostics % vertVelocityTop % array - tangentialVelocity => diagnostics % tangentialVelocity % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - kineticEnergyCell => diagnostics % kineticEnergyCell % array + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergence, timeLevel) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThickness, timeLevel) + + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'montgomeryPotential', montgomeryPotential) + call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) + call mpas_pool_get_array(diagnosticsPool, 'relativeVorticity', relativeVorticity) + call mpas_pool_get_array(diagnosticsPool, 'normalizedRelativeVorticityEdge', normalizedRelativeVorticityEdge) + call mpas_pool_get_array(diagnosticsPool, 'normalizedPlanetaryVorticityEdge', normalizedPlanetaryVorticityEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertAleTransportTop', vertAleTransportTop) + call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'tangentialVelocity', tangentialVelocity) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) allocate(workArray(nVertLevels,nCellsSolve)) @@ -289,9 +294,9 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) - ! vertTransportVelocityTop vertical velocity + ! vertAleTransportTop vertical velocity variableIndex = variableIndex + 1 - workArray = vertTransportVelocityTop(1:nVertLevels,1:nCellsSolve) + workArray = vertAleTransportTop(1:nVertLevels,1:nCellsSolve) call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & workArray, sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & verticalSumMaxes_tmp(variableIndex)) @@ -304,30 +309,34 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ ! lowFreqDivergence variableIndex = variableIndex + 1 - call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & - lowFreqDivergence(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & - verticalSumMaxes_tmp(variableIndex)) - sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) - sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) - mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) - maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) - verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) - verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) - + if (associated(lowFreqDivergence)) then + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + lowFreqDivergence(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + end if + ! highFreqThickness variableIndex = variableIndex + 1 - call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & - highFreqThickness(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & - verticalSumMaxes_tmp(variableIndex)) - sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) - sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) - mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) - maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) - verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) - verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + if (associated(highFreqThickness)) then + call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & + highFreqThickness(:,1:nCellsSolve), sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & + verticalSumMaxes_tmp(variableIndex)) + sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex) + sumSquares(variableIndex) = sumSquares(variableIndex) + sumSquares_tmp(variableIndex) + mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex)) + maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex)) + verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex)) + verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) + end if ! Tracers - do iTracer=1,num_tracers + do iTracer = 1, num_tracers variableIndex = variableIndex + 1 workArray = Tracers(iTracer,:,1:nCellsSolve) call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & @@ -380,11 +389,23 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ nMins = nMins + nVariables nMaxes = nMaxes + nVariables + deallocate(areaEdge) + block => block % next end do call mpas_timer_stop("diagnostic block loop", diagBlockTimer) call mpas_timer_start("diagnostics mpi", .false., diagMPITimer) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diagnostics', diagnosticsPool) + + call mpas_pool_get_array(diagnosticsPool, 'areaCellGlobal', areaCellGlobal) + call mpas_pool_get_array(diagnosticsPool, 'areaEdgeGlobal', areaEdgeGlobal) + call mpas_pool_get_array(diagnosticsPool, 'areaTriangleGlobal', areaTriangleGlobal) + call mpas_pool_get_array(diagnosticsPool, 'volumeCellGlobal', volumeCellGlobal) + call mpas_pool_get_array(diagnosticsPool, 'volumeEdgeGlobal', volumeEdgeGlobal) + call mpas_pool_get_array(diagnosticsPool, 'CFLNumberGlobal', CFLNumberGlobal) + call mpas_pool_get_array(diagnosticsPool, 'xtime', xtime) + ! global reduction of the 5 arrays (packed into 3 to minimize global communication) call mpas_dmpar_sum_real_array(dminfo, nSums, sums(1:nSums), reductions(1:nSums)) sums(1:nVariables) = reductions(1:nVariables) @@ -414,7 +435,7 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ variableIndex = 0 ! time, in days, using a 360 day calendar - read (diagnostics % xtime % scalar, '(i4,5(a1,i2))'), timeYYYY, timeChar, timeMM, timeChar, timeDD, timeChar, timeH, timeChar, timeM, timeChar, timeS + read (xtime, '(i4,10(a1,i2))') timeYYYY, timeChar, timeMM, timeChar, timeDD, timeChar, timeH, timeChar, timeM, timeChar, timeS ! subtract 31.0 because calendar starts on 00-01-01 time_days = timeYYYY*360.0 + timeMM*30.0 + timeDD + (timeH + (timeM + timeS/60.0)/60.0)/24.0 - 31.0 @@ -473,23 +494,35 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ averages(variableIndex) = sums(variableIndex)/volumeCellGlobal rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) - ! vertTransportVelocityTop vertical velocity + ! vertAleTransportTop vertical velocity variableIndex = variableIndex + 1 averages(variableIndex) = sums(variableIndex)/volumeCellGlobal rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) - ! lowFreqDivergence - variableIndex = variableIndex + 1 - averages(variableIndex) = sums(variableIndex)/volumeCellGlobal - rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) - - ! highFreqThickness - variableIndex = variableIndex + 1 - averages(variableIndex) = sums(variableIndex)/volumeCellGlobal - rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + if (associated(lowFreqDivergence) .and. associated(highFreqThickness)) then + ! lowFreqDivergence + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + + ! highFreqThickness + variableIndex = variableIndex + 1 + averages(variableIndex) = sums(variableIndex)/volumeCellGlobal + rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) + else + ! lowFreqDivergence + variableIndex = variableIndex + 1 + averages(variableIndex) = 0.0_RKIND + rms(variableIndex) = 0.0_RKIND + + ! highFreqThickness + variableIndex = variableIndex + 1 + averages(variableIndex) = 0.0_RKIND + rms(variableIndex) = 0.0_RKIND + end if ! Tracers - do iTracer=1,num_tracers + do iTracer = 1, num_tracers variableIndex = variableIndex + 1 averages(variableIndex) = sums(variableIndex)/volumeCellGlobal rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) @@ -497,6 +530,9 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ call mpas_timer_stop("diagnostics mpi", diagMPITimer) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_array(diagnosticsPool, 'xtime', xtime) + ! write out the data to files if (dminfo % my_proc_id == IO_NODE) then fileID = getFreeUnit() @@ -517,7 +553,7 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ close (fileID) open(fileID,file='stats_time.txt',STATUS='UNKNOWN', POSITION='append') write (fileID,'(i10,10x,a,100es24.14)') timeIndex, & - trim(diagnostics % xtime % scalar), dt, & + trim(xtime), dt, & CFLNumberGlobal close (fileID) open(fileID,file='stats_colmin.txt',STATUS='UNKNOWN', POSITION='append') @@ -528,15 +564,6 @@ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{ close (fileID) end if - diagnostics % areaCellGlobal % scalar = areaCellGlobal - diagnostics % areaEdgeGlobal % scalar = areaEdgeGlobal - diagnostics % areaTriangleGlobal % scalar = areaTriangleGlobal - - diagnostics % volumeCellGlobal % scalar = volumeCellGlobal - diagnostics % volumeEdgeGlobal % scalar = volumeEdgeGlobal - diagnostics % CFLNumberGlobal % scalar = CFLNumberGlobal - deallocate(areaEdge) - end subroutine ocn_compute_global_diagnostics!}}} integer function getFreeUnit()!{{{ @@ -916,7 +943,7 @@ subroutine ocn_global_diagnostics_init(dminfo,err)!{{{ write (fileID,'(i5,a)') i,'. pressure'; i=i+1 write (fileID,'(i5,a)') i,'. montgomeryPotential'; i=i+1 write (fileID,'(i5,a)') i,'. vertVelocityTop vertical velocity'; i=i+1 - write (fileID,'(i5,a)') i,'. vertTransportVelocityTop vertical transport'; i=i+1 + write (fileID,'(i5,a)') i,'. vertAleTransportTop vertical transport'; i=i+1 write (fileID,'(i5,a)') i,'. lowFreqDivergence'; i=i+1 write (fileID,'(i5,a)') i,'. highFreqThickness'; i=i+1 write (fileID,'(i5,a)') i,'. Tracers: usually T, S, then others in remaining columns' diff --git a/src/core_ocean/shared/mpas_ocn_gm.F b/src/core_ocean/shared/mpas_ocn_gm.F new file mode 100644 index 0000000000..be89e6f218 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_gm.F @@ -0,0 +1,565 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +module ocn_gm + + use mpas_grid_types + use mpas_configure + use mpas_timer + use mpas_constants + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_gm_compute_Bolus_velocity, & + ocn_gm_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + private :: tridiagonal_solve + + ! Config options + real (kind=RKIND), pointer :: config_gravWaveSpeed_trunc, config_standardGM_tracer_kappa, config_density0, & + config_max_relative_slope, config_Redi_kappa + logical, pointer :: config_use_standardGM + logical, pointer :: config_disable_redi_k33 + + real, parameter :: epsGM = 1.0e-12 + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_gm_compute_Bolus_velocity +! +!> \brief Computes GM Bolus velocity +!> \author Qingshan Chen, Mark Petersen, Todd Ringler +!> \date January 2013 +!> \details +!> This routine is the main driver for the Gent-McWilliams (GM) parameterization. +!> It computes horizontal and vertical density gradients, the slope +!> of isopycnal surfaces, and solves a boundary value problem in each column +!> for the stream function, which is used to compute the Bolus velocity. +! +!----------------------------------------------------------------------- + + subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(inout) :: diagnosticsPool !< Input/Output: Diagnostics information + type (mpas_pool_type), intent(inout) :: scratchPool !< Input/Output: Scratch structure + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + real(kind=RKIND), dimension(:,:), pointer :: density, displacedDensity, zMid, normalGMBolusVelocity, hEddyFlux, layerThicknessEdge, & + gradDensityEdge, gradDensityTopOfEdge, gradDensityConstZTopOfEdge, gradZMidEdge, & + gradZMidTopOfEdge, relativeSlopeTopOfEdge, relativeSlopeTopOfCell, k33, gmStreamFuncTopOfEdge, BruntVaisalaFreqTop, gmStreamFuncTopOfCell, & + dDensityDzTopOfEdge, dDensityDzTopOfCell, relativeSlopeTapering, relativeSlopeTaperingCell, areaCellSum + real(kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, tridiagA, tridiagB, tridiagC, rightHandSide + integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer :: k, iEdge, cell1, cell2, iCell, N + real(kind=RKIND) :: h1, h2, areaEdge, c, BruntVaisalaFreqTopEdge, rtmp, maxSlopeK33 + + ! Dimensions + integer, pointer :: nCells, nEdges + + type (field2DReal), pointer :: gradDensityEdgeField, gradDensityTopOfEdgeField, gradDensityConstZTopOfEdgeField, & + gradZMidEdgeField, gradZMidTopOfEdgeField, dDensityDzTopOfCellField, dDensityDzTopOfEdgeField,areaCellSumField + + type (field1DReal), pointer :: rightHandSideField, tridiagAField, tridiagBField, tridiagCField + + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'displacedDensity', displacedDensity) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfEdge', relativeSlopeTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfCell', relativeSlopeTopOfCell) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTapering', relativeSlopeTapering) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTaperingCell', relativeSlopeTaperingCell) + call mpas_pool_get_array(diagnosticsPool, 'k33', k33) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'hEddyFlux', hEddyFlux) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'BruntVaisalaFreqTop', BruntVaisalaFreqTop) + call mpas_pool_get_array(diagnosticsPool, 'gmStreamFuncTopOfEdge', gmStreamFuncTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'gmStreamFuncTopOfCell', gmStreamFuncTopOfCell) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_field(scratchPool, 'gradDensityEdge', gradDensityEdgeField) + call mpas_pool_get_field(scratchPool, 'gradDensityTopOfEdge', gradDensityTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'gradDensityConstZTopOfEdge', gradDensityConstZTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'dDensityDzTopOfCell', dDensityDzTopOfCellField) + call mpas_pool_get_field(scratchPool, 'dDensityDzTopOfEdge', dDensityDzTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'gradZMidEdge', gradZMidEdgeField) + call mpas_pool_get_field(scratchPool, 'gradZMidTopOfEdge', gradZMidTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'rightHandSide', rightHandSideField) + call mpas_pool_get_field(scratchPool, 'tridiagA', tridiagAField) + call mpas_pool_get_field(scratchPool, 'tridiagB', tridiagBField) + call mpas_pool_get_field(scratchPool, 'tridiagC', tridiagCField) + call mpas_pool_get_field(scratchPool, 'areaCellSum', areaCellSumField) + + call mpas_allocate_scratch_field(gradDensityEdgeField, .True.) + call mpas_allocate_scratch_field(gradDensityTopOfEdgeField, .True.) + call mpas_allocate_scratch_field(gradDensityConstZTopOfEdgeField, .True.) + call mpas_allocate_scratch_field(dDensityDzTopOfCellField, .True.) + call mpas_allocate_scratch_field(dDensityDzTopOfEdgeField, .True.) + call mpas_allocate_scratch_field(gradZMidEdgeField, .True.) + call mpas_allocate_scratch_field(gradZMidTopOfEdgeField, .True.) + call mpas_allocate_scratch_field(rightHandSideField, .True.) + call mpas_allocate_scratch_field(tridiagAField, .True.) + call mpas_allocate_scratch_field(tridiagBField, .True.) + call mpas_allocate_scratch_field(tridiagCField, .True.) + call mpas_allocate_scratch_field(areaCellSumField, .True.) + + gradDensityEdge => gradDensityEdgeField % array + gradDensityTopOfEdge => gradDensityTopOfEdgeField % array + gradDensityConstZTopOfEdge => gradDensityConstZTopOfEdgeField % array + dDensityDzTopOfCell => dDensityDzTopOfCellField % array + dDensityDzTopOfEdge => dDensityDzTopOfEdgeField % array + gradZMidEdge => gradZMidEdgeField % array + gradZMidTopOfEdge => gradZMidTopOfEdgeField % array + rightHandSide => rightHandSideField % array + tridiagA => tridiagAField % array + tridiagB => tridiagBField % array + tridiagC => tridiagCField % array + areaCellSum => areaCellSumField % array + + ! Assign a huge value to the scratch variables which may manifest itself when + ! there is a bug. + gradDensityEdge(:,:) = huge(0D0) + gradDensityTopOfEdge(:,:) = huge(0D0) + dDensityDzTopOfCell(:,:) = huge(0D0) + dDensityDzTopOfEdge(:,:) = huge(0D0) + gradZMidEdge(:,:) = huge(0D0) + gradZMidTopOfEdge(:,:) = huge(0D0) + + relativeSlopeTopOfEdge(:,:) = 0.0 + relativeSlopeTopOfCell(:,:) = 0.0 + relativeSlopeTapering(:,:) = 0.0 + relativeSlopeTaperingCell(:,:) = 0.0 + k33(:,:) = 0.0 + normalGMBolusVelocity(:,:) = 0.0 + + !-------------------------------------------------------------------- + ! + ! Compute vertical derivative of density at top of cell, interpolate to top of edge + ! This is required for Redi and Bolus parts. + ! + !-------------------------------------------------------------------- + + ! Compute vertical derivative of density (dDensityDzTopOfCell) at cell center and layer interface + ! Note that displacedDensity is used from the upper cell, so that the EOS reference level for + ! pressure is the same for both displacedDensity(k-1,iCell) and density(k,iCell). + do iCell = 1, nCells + do k = 2, maxLevelCell(iCell) + rtmp = (displacedDensity(k-1,iCell) - density(k,iCell)) / (zMid(k-1,iCell) - zMid(k,iCell)) + dDensityDzTopOfCell(k,iCell) = min(rtmp, -epsGM) + end do + + ! Approximation of dDensityDzTopOfCell on the top and bottom interfaces through the idea of having + ! ghost cells above the top and below the bottom layers of the same depths and density. + ! Essentially, this enforces the boundary condition (d density)/dz = 0 at the top and bottom. + dDensityDzTopOfCell(1,iCell) = 0.0 + dDensityDzTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0 + end do + + ! Interpolate dDensityDzTopOfCell to edge and layer interface + do iEdge = 1, nEdges + do k = 1, maxLevelEdgeTop(iEdge)+1 + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + dDensityDzTopOfEdge(k,iEdge) = 0.5 * (dDensityDzTopOfCell(k,cell1) + dDensityDzTopOfCell(k,cell2)) + end do + end do + + !-------------------------------------------------------------------- + ! + ! Compute horizontal gradient and mid-layer of edge, interpolate to top of edge + ! This is required for Redi and Bolus parts. + ! + !-------------------------------------------------------------------- + + ! Compute density gradient (gradDensityEdge) and gradient of zMid (gradZMidEdge) + ! along the constant coordinate surface. + ! The computed variables lives at edge and mid-layer depth + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,maxLevelEdgeTop(iEdge) + gradDensityEdge(k,iEdge) = (density(k,cell2) - density(k,cell1)) / dcEdge(iEdge) + gradZMidEdge(k,iEdge) = (zMid(k,cell2) - zMid(k,cell1)) / dcEdge(iEdge) + end do + end do + + ! Interpolate gradDensityEdge and gradZMidEdge to layer interface + do iEdge = 1, nEdges + ! The interpolation can only be carried out on non-boundary edges + if (maxLevelEdgeTop(iEdge) .GE. 1) then + do k = 2, maxLevelEdgeTop(iEdge) + h1 = layerThicknessEdge(k-1,iEdge) + h2 = layerThicknessEdge(k,iEdge) + ! Using second-order interpolation below + gradDensityTopOfEdge(k,iEdge) = (h2 * gradDensityEdge(k-1,iEdge) + h1 * gradDensityEdge(k,iEdge)) / (h1 + h2) + gradZMidTopOfEdge(k,iEdge) = (h2 * gradZMidEdge(k-1,iEdge) + h1 * gradZMidEdge(k,iEdge)) / (h1 + h2) + + end do + + ! Approximation of values on the top and bottom interfaces through the idea of having ghost cells above + ! the top and below the bottom layers of the same depths and density. + gradDensityTopOfEdge(1,iEdge) = gradDensityEdge(1,iEdge) + gradDensityTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = gradDensityEdge(maxLevelEdgeTop(iEdge),iEdge) + gradZMidTopOfEdge(1,iEdge) = gradZMidEdge(1,iEdge) + gradZMidTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = gradZMidEdge(maxLevelEdgeTop(iEdge),iEdge) + end if + end do + + !-------------------------------------------------------------------- + ! + ! Compute horizontal gradient required for Bolus part (along constant z) + ! + !-------------------------------------------------------------------- + + do iEdge = 1, nEdges + if (maxLevelEdgeTop(iEdge) .GE. 1) then + do k = 1, maxLevelEdgeTop(iEdge)+1 + gradDensityConstZTopOfEdge(k,iEdge) = gradDensityTopOfEdge(k,iEdge) - dDensityDzTopOfEdge(k,iEdge) * gradZMidTopOfEdge(k,iEdge) + end do + end if + end do + + !-------------------------------------------------------------------- + ! + ! Compute relative slope and k33 for Redi part of GM. + ! These variables are used in del2 velocity tendency routines. + ! + !-------------------------------------------------------------------- + + ! Compute relativeSlopeTopOfEdge at edge and layer interface + ! set relativeSlopeTopOfEdge to zero for horizontal land/water edges. + relativeSlopeTopOfEdge = 0.0 + do iEdge = 1, nEdges + + ! Beside a full land cell (e.g. missing cell) maxLevelEdgeTop=0, so relativeSlopeTopOfEdge at that edge will remain zero. + do k = 2, maxLevelEdgeTop(iEdge) + relativeSlopeTopOfEdge(k,iEdge) = - gradDensityTopOfEdge(k,iEdge) / min(dDensityDzTopOfEdge(k,iEdge),-epsGM) + end do + + ! Since dDensityDzTopOfEdge is guaranteed to be zero on the top surface, relativeSlopeTopOfEdge on the top surface is identified with its value on the second interface. + relativeSlopeTopOfEdge(1,iEdge) = relativeSlopeTopOfEdge(2,iEdge) + + ! dDensityDzTopOfEdge may or may not equal zero on the bottom surface, depending on whether maxLevelEdgeTop(iEdge) = maxLevelEdgeBottom(iEdge). But here we + ! take a simplistic approach and identify relativeSlopeTopOfEdge on the bottom surface with its value on the interface just above. + relativeSlopeTopOfEdge( maxLevelEdgeTop(iEdge)+1, iEdge ) = relativeSlopeTopOfEdge( max(1,maxLevelEdgeTop(iEdge)), iEdge ) + + end do + + ! slope can be unbounded in regions of neutral stability, reset to the large, but bounded, value + ! values is hardwrite to 1.0, this is equivalent to a slope of 45 degrees + where(relativeSlopeTopOfEdge < -1.0) relativeSlopeTopOfEdge = -1.0 + where(relativeSlopeTopOfEdge > 1.0) relativeSlopeTopOfEdge = 1.0 + + ! average relative slope to cell centers + ! do this by computing (relative slope)^2, then taking sqrt + areaCellSum = 1.0e-34 + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + ! contribution of cell area from this edge: + areaEdge = 0.25 * dcEdge(iEdge) * dvEdge(iEdge) + + do k = 1, maxLevelEdgeTop(iEdge) + + ! only one component is summed (thus the weighting by a factor of 2.0) + rtmp = 2.0 * areaEdge * relativeSlopeTopOfEdge(k,iEdge)**2 + relativeSlopeTopOfCell(k,cell1) = relativeSlopeTopOfCell(k,cell1) + rtmp + relativeSlopeTopOfCell(k,cell2) = relativeSlopeTopOfCell(k,cell2) + rtmp + + areaCellSum(k,cell1) = areaCellSum(k,cell1) + areaEdge + areaCellSum(k,cell2) = areaCellSum(k,cell2) + areaEdge + + end do + end do + do iCell=1,nCells + do k = 1, maxLevelCell(iCell) + relativeSlopeTopOfCell(k,iCell) = sqrt(relativeSlopeTopOfCell(k,iCell)/areaCellSum(k,iCell)) + end do + end do + + ! Compute tapering function + ! Compute k33 at cell center and layer interface + k33(:,:) = 0.0 + do iCell=1,nCells + do k = 2, maxLevelCell(iCell) + relativeSlopeTaperingCell(k,iCell) = min(1.0, config_max_relative_slope**2 / (relativeSlopeTopOfCell(k,iCell)**2+epsGM)) + k33(k,iCell) = relativeSlopeTaperingCell(k,iCell) * (relativeSlopeTopOfCell(k,iCell))**2 + end do + end do + + ! average tapering function to layer edges + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + do k = 2, maxLevelEdgeTop(iEdge) + relativeSlopeTapering(k,iEdge) = 0.5 * (relativeSlopeTaperingCell(k,cell1) + relativeSlopeTaperingCell(k,cell2)) + enddo + enddo + + ! k33 is still non-dimensional measuring the limited (relative slope)^2 of neutral surfaces. + ! scale k33 by config_Redi_kappa so it has units of diffusivity + k33 = config_Redi_kappa * k33 + + ! allow disabling of K33 for testing + if(config_disable_redi_k33) k33=0.0 + + !-------------------------------------------------------------------- + ! + ! Compute stream function and Bolus velocity for Bolus part of GM + ! + !-------------------------------------------------------------------- + + gmStreamFuncTopOfEdge(:,:) = 0.0 + c = config_gravWaveSpeed_trunc**2 + do iEdge = 1, nEdges + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! Construct the tridiagonal matrix + if (maxLevelEdgeTop(iEdge) .GE. 3) then + ! First row + k = 2 + BruntVaisalaFreqTopEdge = 0.5 * (BruntVaisalaFreqTop(k,cell1) + BruntVaisalaFreqTop(k,cell2)) + BruntVaisalaFreqTopEdge = max(BruntVaisalaFreqTopEdge, 0.0) + tridiagB(k-1) = - 2.*config_gravWaveSpeed_trunc**2/(layerThicknessEdge(k-1,iEdge)*layerThicknessEdge(k,iEdge)) - BruntVaisalaFreqTopEdge + tridiagC(k-1) = 2.*config_gravWaveSpeed_trunc**2/layerThicknessEdge(k,iEdge)/(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) + rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / config_density0 * gradDensityConstZTopOfEdge(k,iEdge) + + ! Second to next to the last rows + do k = 3, maxLevelEdgeTop(iEdge)-1 + BruntVaisalaFreqTopEdge = 0.5 * (BruntVaisalaFreqTop(k,cell1) + BruntVaisalaFreqTop(k,cell2)) + BruntVaisalaFreqTopEdge = max(BruntVaisalaFreqTopEdge, 0.0) + tridiagA(k-2) = 2.*config_gravWaveSpeed_trunc**2/layerThicknessEdge(k-1,iEdge)/(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) + tridiagB(k-1) = - 2.*config_gravWaveSpeed_trunc**2/(layerThicknessEdge(k-1,iEdge)*layerThicknessEdge(k,iEdge)) - BruntVaisalaFreqTopEdge + tridiagC(k-1) = 2.*config_gravWaveSpeed_trunc**2/layerThicknessEdge(k,iEdge)/(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) + rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / config_density0 * gradDensityConstZTopOfEdge(k,iEdge) + end do + + ! Last row + k = maxLevelEdgeTop(iEdge) + BruntVaisalaFreqTopEdge = 0.5 * (BruntVaisalaFreqTop(k,cell1) + BruntVaisalaFreqTop(k,cell2)) + BruntVaisalaFreqTopEdge = max(BruntVaisalaFreqTopEdge, 0.0) + tridiagA(k-2) = 2.*config_gravWaveSpeed_trunc**2/layerThicknessEdge(k-1,iEdge)/(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) + tridiagB(k-1) = - 2.0*config_gravWaveSpeed_trunc**2/(layerThicknessEdge(k-1,iEdge)*layerThicknessEdge(k,iEdge)) - BruntVaisalaFreqTopEdge + rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / config_density0 * gradDensityConstZTopOfEdge(k,iEdge) + + ! Total number of rows + N = maxLevelEdgeTop(iEdge) - 1 + + ! Call the tridiagonal solver + call tridiagonal_solve(tridiagA, tridiagB, tridiagC, rightHandSide, gmStreamFuncTopOfEdge(2:maxLevelEdgeTop(iEdge),iEdge), N) + end if + + end do + + ! Compute normalGMBolusVelocity from the stream function + do iEdge = 1, nEdges + do k = 1, maxLevelEdgeTop(iEdge) + normalGMBolusVelocity(k,iEdge) = (gmStreamFuncTopOfEdge(k,iEdge) - gmStreamFuncTopOfEdge(k+1,iEdge)) / layerThicknessEdge(k,iEdge) + end do + end do + + ! Interpolate gmStreamFuncTopOfEdge to cell centers for visualization + gmStreamFuncTopOfCell(:,:) = 0.0 + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + areaEdge = 0.25 * dcEdge(iEdge) * dvEdge(iEdge) + + do k = 1, maxLevelEdgeTop(iEdge) + rtmp = 0.5 * ( gmStreamFuncTopOfEdge(k,iEdge) + gmStreamFuncTopOfEdge(k+1,iEdge) ) * areaEdge + gmStreamFuncTopOfCell(k,cell1) = gmStreamFuncTopOfCell(k,cell1) + rtmp + gmStreamFuncTopOfCell(k,cell2) = gmStreamFuncTopOfCell(k,cell2) + rtmp + end do + + end do + do iCell = 1, nCells + gmStreamFuncTopOfCell(:, iCell) = gmStreamFuncTopOfCell(:,iCell) / areaCell(iCell) + end do + + ! Deallocate scratch variables + call mpas_deallocate_scratch_field(gradDensityEdgeField, .true.) + call mpas_deallocate_scratch_field(gradDensityTopOfEdgeField, .true.) + call mpas_deallocate_scratch_field(gradDensityConstZTopOfEdgeField, .true.) + call mpas_deallocate_scratch_field(dDensityDzTopOfCellField, .true.) + call mpas_deallocate_scratch_field(dDensityDzTopOfEdgeField, .true.) + call mpas_deallocate_scratch_field(gradZMidEdgeField, .true.) + call mpas_deallocate_scratch_field(gradZMidTopOfEdgeField, .true.) + call mpas_deallocate_scratch_field(rightHandSideField, .true.) + call mpas_deallocate_scratch_field(tridiagAField, .true.) + call mpas_deallocate_scratch_field(tridiagBField, .true.) + call mpas_deallocate_scratch_field(tridiagCField, .true.) + + end subroutine ocn_gm_compute_Bolus_velocity!}}} + +!*********************************************************************** +! +! routine tridiagonal_solve +! +!> \brief Solve the matrix equation Ax=r for x, where A is tridiagonal. +!> \author Mark Petersen +!> \date September 2011 +!> \details +!> Solve the matrix equation Ax=r for x, where A is tridiagonal. +!> A is an nxn matrix, with: +!> a sub-diagonal, filled from 1:n-1 (a(1) appears on row 2) +!> b diagonal, filled from 1:n +!> c sup-diagonal, filled from 1:n-1 (c(1) apears on row 1) +! +!----------------------------------------------------------------------- +! mrp note: This subroutine also appears in vmix and should really be put in the framework. + subroutine tridiagonal_solve(a,b,c,r,x,n) !{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer,intent(in) :: n + real (KIND=RKIND), dimension(n), intent(in) :: a,b,c,r + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (KIND=RKIND), dimension(n), intent(out) :: x + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + real (KIND=RKIND), dimension(n) :: bTemp,rTemp + real (KIND=RKIND) :: m + integer i + + call mpas_timer_start("tridiagonal_solve") + + ! Use work variables for b and r + bTemp(1) = b(1) + rTemp(1) = r(1) + + ! First pass: set the coefficients + do i = 2,n + m = a(i-1)/bTemp(i-1) + bTemp(i) = b(i) - m*c(i-1) + rTemp(i) = r(i) - m*rTemp(i-1) + end do + + x(n) = rTemp(n)/bTemp(n) + ! Second pass: back-substition + do i = n-1, 1, -1 + x(i) = (rTemp(i) - c(i)*x(i+1))/bTemp(i) + end do + + call mpas_timer_stop("tridiagonal_solve") + + end subroutine tridiagonal_solve !}}} + +!*********************************************************************** +! +! routine ocn_gm_init +! +!> \brief Initializes ocean momentum horizontal pressure gradient +!> \author Mark Petersen +!> \date September 2011 +!> \details +!> This routine initializes parameters required for the computation of the +!> horizontal pressure gradient. +! +!----------------------------------------------------------------------- + + subroutine ocn_gm_init(err)!{{{ + + !----------------------------------------------------------------- + ! + ! Output Variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_gravWaveSpeed_trunc',config_gravWaveSpeed_trunc) + call mpas_pool_get_config(ocnConfigs, 'config_standardGM_tracer_kappa',config_standardGM_tracer_kappa) + call mpas_pool_get_config(ocnConfigs, 'config_max_relative_slope',config_max_relative_slope) + call mpas_pool_get_config(ocnConfigs, 'config_density0',config_density0) + call mpas_pool_get_config(ocnConfigs, 'config_Redi_kappa', config_Redi_kappa) + call mpas_pool_get_config(ocnConfigs, 'config_use_standardGM',config_use_standardGM) + call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_k33',config_disable_redi_k33) + + end subroutine ocn_gm_init!}}} + +!*********************************************************************** + +end module ocn_gm + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_high_freq_thickness_hmix_del2.F b/src/core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F similarity index 66% rename from src/core_ocean/mpas_ocn_high_freq_thickness_hmix_del2.F rename to src/core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F index 139b89fa12..669eb90c76 100644 --- a/src/core_ocean/mpas_ocn_high_freq_thickness_hmix_del2.F +++ b/src/core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F @@ -21,7 +21,7 @@ module ocn_high_freq_thickness_hmix_del2 use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -39,7 +39,18 @@ module ocn_high_freq_thickness_hmix_del2 ! !-------------------------------------------------------------------- - public :: ocn_high_freq_thickness_hmix_del2_tend + public :: ocn_high_freq_thickness_hmix_del2_tend, & + ocn_high_freq_thickness_hmix_del2_init + + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + logical, pointer :: config_use_highFreqThick_del2 + real (kind=RKIND), pointer :: config_highFreqThick_del2 !*********************************************************************** @@ -59,7 +70,7 @@ module ocn_high_freq_thickness_hmix_del2 ! !----------------------------------------------------------------------- - subroutine ocn_high_freq_thickness_hmix_del2_tend(mesh, highFreqThickness, tend_highFreqThickness, err)!{{{ + subroutine ocn_high_freq_thickness_hmix_del2_tend(meshPool, highFreqThickness, tend_highFreqThickness, err)!{{{ !----------------------------------------------------------------- ! @@ -67,8 +78,8 @@ subroutine ocn_high_freq_thickness_hmix_del2_tend(mesh, highFreqThickness, tend_ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & highFreqThickness !< Input: high frequency thickness @@ -96,7 +107,8 @@ subroutine ocn_high_freq_thickness_hmix_del2_tend(mesh, highFreqThickness, tend_ ! !----------------------------------------------------------------- - integer :: iCell, iEdge, nCells, nVertLevels, cell1, cell2, i, k + integer :: iCell, iEdge, cell1, cell2, i, k + integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnCell integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask, edgesOnCell, edgeSignOnCell @@ -109,20 +121,20 @@ subroutine ocn_high_freq_thickness_hmix_del2_tend(mesh, highFreqThickness, tend_ if(.not.config_use_highFreqThick_del2) return - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - cellsOnEdge => mesh % cellsOnEdge % array - edgeMask => mesh % edgeMask % array - areaCell => mesh % areaCell % array - dvEdge => mesh % dvEdge % array - dcEdge => mesh % dcEdge % array - meshScalingDel2 => mesh % meshScalingDel2 % array + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'meshScalingDel2', meshScalingDel2) - nEdgesOnCell => mesh % nEdgesOnCell % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnCell => mesh % edgeSignOnCell % array + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) @@ -149,6 +161,29 @@ subroutine ocn_high_freq_thickness_hmix_del2_tend(mesh, highFreqThickness, tend_ end subroutine ocn_high_freq_thickness_hmix_del2_tend!}}} !*********************************************************************** +! +! routine ocn_high_freq_thickness_hmix_del2_init +! +!> \brief Initializes horizontal highFreqThickness mixing +!> \author Mark Petersen +!> \date July 2013 +!> \details +!> This routine initializes the module for horizontal mixing of +!> high frequency thickness +!> +! +!----------------------------------------------------------------------- + + subroutine ocn_high_freq_thickness_hmix_del2_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_highFreqThick_del2', config_use_highFreqThick_del2) + call mpas_pool_get_config(ocnConfigs, 'config_highFreqThick_del2', config_highFreqThick_del2) + + end subroutine ocn_high_freq_thickness_hmix_del2_init!}}} end module ocn_high_freq_thickness_hmix_del2 diff --git a/src/core_ocean/shared/mpas_ocn_init.F b/src/core_ocean/shared/mpas_ocn_init.F new file mode 100644 index 0000000000..75a04626f7 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_init.F @@ -0,0 +1,570 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! mpas_init +! +!> \brief MPAS-ocean initialization routines. +!> \author Mark Petersen +!> \date December 2013 +!> \details +!> This module contains routines to initialize variables at the +!> beginning of an MPAS-Ocean simulation, or when starting the +!> ocean analysis core. +! +!----------------------------------------------------------------------- + +module ocn_init + + use mpas_framework + use mpas_dmpar + use ocn_constants + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: & + ocn_compute_max_level, & + ocn_compute_mesh_scaling, & + ocn_setup_sign_and_index_fields, & + ocn_init_vert_coord + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_compute_max_level +! +!> \brief initialize max level and boundary mask variables +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine initializes max level and boundary mask variables +! +!----------------------------------------------------------------------- +subroutine ocn_compute_max_level(domain)!{{{ +! Initialize maxLevel and boundary mesh variables. + + use mpas_grid_types + use mpas_constants + + implicit none + + type (domain_type), intent(inout) :: domain + type (mpas_pool_type), pointer :: meshPool + + integer :: i, iCell, iEdge, iVertex, k + type (block_type), pointer :: block + + integer, pointer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree + + integer, dimension(:), pointer :: & + maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, & + maxLevelVertexTop, maxLevelVertexBot + integer, dimension(:,:), pointer :: & + cellsOnEdge, cellsOnVertex, boundaryEdge, boundaryCell, & + boundaryVertex, verticesOnEdge, edgeMask, cellMask, vertexMask + + ! Initialize z-level mesh variables from h, read in from input file. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + call mpas_pool_get_array(meshPool, 'maxLevelVertexTop', maxLevelVertexTop) + call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'boundaryEdge', boundaryEdge) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) + call mpas_pool_get_array(meshPool, 'boundaryVertex', boundaryVertex) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'cellMask', cellMask) + call mpas_pool_get_array(meshPool, 'vertexMask', vertexMask) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertices ', nVertices) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + ! maxLevelEdgeTop is the minimum (shallowest) of the surrounding cells + do iEdge = 1, nEdges + maxLevelEdgeTop(iEdge) = & + min( maxLevelCell(cellsOnEdge(1,iEdge)), & + maxLevelCell(cellsOnEdge(2,iEdge)) ) + end do + maxLevelEdgeTop(nEdges+1) = 0 + + ! maxLevelEdgeBot is the maximum (deepest) of the surrounding cells + do iEdge = 1, nEdges + maxLevelEdgeBot(iEdge) = & + max( maxLevelCell(cellsOnEdge(1,iEdge)), & + maxLevelCell(cellsOnEdge(2,iEdge)) ) + end do + maxLevelEdgeBot(nEdges+1) = 0 + + ! maxLevelVertexBot is the maximum (deepest) of the surrounding cells + do iVertex = 1,nVertices + maxLevelVertexBot(iVertex) = maxLevelCell(cellsOnVertex(1,iVertex)) + do i = 2, vertexDegree + maxLevelVertexBot(iVertex) = & + max( maxLevelVertexBot(iVertex), & + maxLevelCell(cellsOnVertex(i,iVertex))) + end do + end do + maxLevelVertexBot(nVertices+1) = 0 + + ! maxLevelVertexTop is the minimum (shallowest) of the surrounding cells + do iVertex = 1,nVertices + maxLevelVertexTop(iVertex) = maxLevelCell(cellsOnVertex(1,iVertex)) + do i = 2, vertexDegree + maxLevelVertexTop(iVertex) = & + min( maxLevelVertexTop(iVertex), & + maxLevelCell(cellsOnVertex(i,iVertex))) + end do + end do + maxLevelVertexTop(nVertices+1) = 0 + + ! set boundary edge + boundaryEdge(:,1:nEdges+1)=1 + edgeMask(:,1:nEdges+1)=0 + do iEdge = 1, nEdges + boundaryEdge(1:maxLevelEdgeTop(iEdge),iEdge)=0 + edgeMask(1:maxLevelEdgeTop(iEdge),iEdge)=1 + end do + + ! + ! Find cells and vertices that have an edge on the boundary + ! + boundaryCell(:,1:nCells+1) = 0 + cellMask(:,1:nCells+1) = 0 + boundaryVertex(:,1:nVertices+1) = 0 + vertexMask(:,1:nVertices+1) = 0 + do iEdge = 1, nEdges + do k = 1, nVertLevels + if (boundaryEdge(k,iEdge).eq.1) then + boundaryCell(k,cellsOnEdge(1,iEdge)) = 1 + boundaryCell(k,cellsOnEdge(2,iEdge)) = 1 + boundaryVertex(k,verticesOnEdge(1,iEdge)) = 1 + boundaryVertex(k,verticesOnEdge(2,iEdge)) = 1 + endif + end do + end do + + do iCell = 1, nCells + do k = 1, nVertLevels + if ( maxLevelCell(iCell) >= k ) then + cellMask(k, iCell) = 1 + end if + end do + end do + + do iVertex = 1, nVertices + do k = 1, nVertLevels + if ( maxLevelVertexBot(iVertex) >= k ) then + vertexMask(k, iVertex) = 1 + end if + end do + end do + + block => block % next + end do + + ! Note: We do not update halos on maxLevel* variables. I want the + ! outside edge of a halo to be zero on each processor. + +end subroutine ocn_compute_max_level!}}} + +!*********************************************************************** +! +! routine ocn_setup_sign_and_index_fields +! +!> \brief set up sign and index fields +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine initializes edgeSignOnCell, edgeSignOnVertex, and +!> kiteIndexOnCell. +! +!----------------------------------------------------------------------- + subroutine ocn_setup_sign_and_index_fields(meshPool)!{{{ + + type (mpas_pool_type), intent(inout) :: meshPool + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell, edgesOnVertex, cellsOnVertex, cellsOnEdge, verticesOnCell, verticesOnEdge + integer, dimension(:,:), pointer :: edgeSignOnCell, edgeSignOnVertex, kiteIndexOnCell + + integer, pointer :: nCells, nEdges, nVertices, vertexDegree + integer :: iCell, iEdge, iVertex, i, j, k + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnVertex', edgeSignOnVertex) + call mpas_pool_get_array(meshPool, 'kiteIndexOnCell', kiteIndexOnCell) + + 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!}}} + +!*********************************************************************** +! +! routine ocn_compute_mesh_scaling +! +!> \brief set up mesh scaling variables +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine initializes meshScaling, meshScalingDel2, and +!> meshScalingDel4 +! +!----------------------------------------------------------------------- + subroutine ocn_compute_mesh_scaling(meshPool, scaleHmixWithMesh, maxMeshDensity)!{{{ + + use mpas_grid_types + + implicit none + + type (mpas_pool_type), intent(inout) :: meshPool + logical, intent(in) :: scaleHmixWithMesh + real (kind=RKIND), intent(in) :: maxMeshDensity + + integer :: iEdge, cell1, cell2 + integer, pointer :: nEdges + integer, dimension(:,:), pointer :: cellsOnEdge + real (kind=RKIND), dimension(:), pointer :: meshDensity, meshScalingDel2, meshScalingDel4, meshScaling + + call mpas_pool_get_array(meshPool, 'meshDensity', meshDensity) + call mpas_pool_get_array(meshPool, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(meshPool, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array(meshPool, 'meshScaling', meshScaling) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + ! + ! Compute the scaling factors to be used in the del2 and del4 dissipation + ! + meshScalingDel2(:) = 1.0 + meshScalingDel4(:) = 1.0 + meshScaling(:) = 1.0 + if (scaleHmixWithMesh) then + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + meshScalingDel2(iEdge) = 1.0 / ( ((meshDensity(cell1) + meshDensity(cell2) ) / 2.0) / maxMeshDensity)**(3.0 / 4.0) ! goes as dc**3 + meshScalingDel4(iEdge) = 1.0 / ( ((meshDensity(cell1) + meshDensity(cell2) ) / 2.0) / maxMeshDensity)**(3.0 / 4.0) ! goes as dc**3 + meshScaling(iEdge) = 1.0 / ( ((meshDensity(cell1) + meshDensity(cell2) ) / 2.0) / maxMeshDensity)**(1.0 / 4.0) + end do + end if + + end subroutine ocn_compute_mesh_scaling!}}} + +!*********************************************************************** +! +! routine ocn_init_vert_coord +! +!> \brief initialize vertical coordinate variables +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine initializes vertical coordinate 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 + + implicit none + + type (domain_type), intent(inout) :: domain + + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: verticalMeshPool + type (dm_info) :: dminfo + + integer :: i, iCell, iEdge, iVertex, k, km1 + type (block_type), pointer :: block + + integer :: iTracer, cell, cell1, cell2 + real (kind=RKIND) :: normalThicknessFluxSum, thicknessSum, hEdge1, zMidPBC + + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, & + refBottomDepthTopOfCell, vertCoordMovementWeights, bottomDepth, refZMid, refLayerThickness + real (kind=RKIND), dimension(:), allocatable :: minBottomDepth, minBottomDepthMid, zMidZLevel + + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + integer, pointer :: nVertLevels, nCells, num_tracers + logical :: consistentSSH + + real (kind=RKIND), pointer :: config_min_pbc_fraction + logical, pointer :: config_do_restart, config_alter_ICs_for_pbcs, config_check_ssh_consistency + logical, pointer :: config_check_zlevel_consistency, config_set_restingThickness_to_IC + character (len=StrKIND), pointer :: config_vert_coord_movement, config_pbc_alteration_type + + call mpas_pool_get_config(domain % configs, 'config_vert_coord_movement', config_vert_coord_movement) + call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(domain % configs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) + call mpas_pool_get_config(domain % configs, 'config_pbc_alteration_type', config_pbc_alteration_type) + call mpas_pool_get_config(domain % configs, 'config_check_ssh_consistency', config_check_ssh_consistency) + call mpas_pool_get_config(domain % configs, 'config_check_zlevel_consistency', config_check_zlevel_consistency) + call mpas_pool_get_config(domain % configs, 'config_min_pbc_fraction', config_min_pbc_fraction) + call mpas_pool_get_config(domain % configs, 'config_set_restingThickness_to_IC', config_set_restingThickness_to_IC) + + ! Initialize z-level mesh variables from h, read in from input file. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'verticalMesh', verticalMeshPool) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'refBottomDepthTopOfCell', refBottomDepthTopOfCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'refLayerThickness', refLayerThickness) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + + ! TopOfCell needed where zero depth for the very top may be referenced. + refBottomDepthTopOfCell(1) = 0.0 + do k = 1, nVertLevels + refBottomDepthTopOfCell(k+1) = refBottomDepth(k) + refLayerThickness(k) = refBottomDepth(k) - refBottomDepthTopOfCell(k) + refZMid(k) = - refBottomDepthTopOfCell(k) - refLayerThickness(k)/2.0 + end do + + ! Initialization of vertCoordMovementWeights. This determines how SSH perturbations + ! are distributed throughout the column. + if (config_vert_coord_movement.eq.'fixed') then + + vertCoordMovementWeights = 0.0 + vertCoordMovementWeights(1) = 1.0 + + elseif (config_vert_coord_movement.eq.'uniform_stretching') then + + 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 .and. config_alter_ICs_for_pbcs) then + + if (config_pbc_alteration_type .eq. 'partial_cell') then + + write (stdoutUnit,'(a)') ' Altering bottomDepth to avoid very thin cells.' + write (stdoutUnit,'(a)') ' Altering layerThickness 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. + + minBottomDepth(1) = (1.0-config_min_pbc_fraction)*refBottomDepth(1) + minBottomDepthMid(1) = 0.5*(minBottomDepth(1) + refBottomDepthTopOfCell(1)) + zMidZLevel(1) = - 0.5*(refBottomDepth(1) + refBottomDepthTopOfCell(1)) + do k = 2, nVertLevels + minBottomDepth(k) = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) + minBottomDepthMid(k) = 0.5*(minBottomDepth(k) + refBottomDepthTopOfCell(k)) + zMidZLevel(k) = - 0.5*(refBottomDepth(k) + refBottomDepthTopOfCell(k)) + enddo + + do iCell = 1, nCells + + ! Change value of maxLevelCell for partial bottom cells + k = maxLevelCell(iCell) + 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 + ! reset k to new value of maxLevelCell + k = maxLevelCell(iCell) + + ! Alter thickness of bottom level to account for PBC + layerThickness(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)) + km1 = max(k-1,1) + do iTracer = 1, num_tracers + tracers(iTracer,k,iCell) = tracers(iTracer,k,iCell) & + + (tracers(iTracer,km1,iCell) - tracers(iTracer,k,iCell)) & + /(zMidZLevel(km1)-zMidZLevel(k)+1.0e-16) & + *(zMidPBC - zMidZLevel(k)) + enddo + + enddo + + deallocate(minBottomDepth,zMidZLevel) + + elseif (config_pbc_alteration_type .eq. 'full_cell') then + + do iCell = 1,nCells + bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) + enddo + + else + + write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' + call mpas_dmpar_abort(dminfo) + + endif + + endif ! .not.config_do_restart + + if (.not. config_do_restart) then + + ! Layer thickness when the ocean is at rest, i.e. without SSH or internal perturbations. + ! This is applied only from the initial condition + if (config_set_restingThickness_to_IC) then + restingThickness = layerThickness + endif + + endif ! .not.config_do_restart.and.config_alter_ICs_for_pbcs + + if (config_check_ssh_consistency) then + consistentSSH = .true. + do iCell = 1,nCells + ! Check if abs(ssh)>2m. If so, print warning. + if (abs(sum(layerThickness(1:maxLevelCell(iCell),iCell))-bottomDepth(iCell))>2.0) then + consistentSSH = .false. + write (stderrUnit,'(a)') ' Warning: abs(sum(h)-bottomDepth)>2m. Most likely, initial layerThickness does not match bottomDepth.' + write (stderrUnit,*) ' iCell, K=maxLevelCell(iCell), bottomDepth(iCell),sum(h),bottomDepth: ', & + iCell, maxLevelCell(iCell), bottomDepth(iCell),sum(layerThickness(1:maxLevelCell(iCell),iCell)),bottomDepth(iCell), & + layerThickness(maxLevelCell(iCell),iCell) + endif + enddo + + if (.not. consistentSSH) then + write(stderrUnit,*) 'Warning: SSH is not consistent. Most likely, initial layerThickness does not match bottomDepth.' + end if + + endif ! config_check_ssh_consistency + + if (config_check_zlevel_consistency) then + do iCell = 1,nCells + ! Check that bottomDepth and maxLevelCell match. Some older meshs do not have the bottomDepth variable. + if (bottomDepth(iCell) > refBottomDepth(maxLevelCell(iCell)).or. & + bottomDepth(iCell) < refBottomDepthTopOfCell(maxLevelCell(iCell))) then + write (stderrUnit,'(a)') ' fatal error: bottomDepth and maxLevelCell do not match:' + write (stderrUnit,'(a,2i5,10f10.2)') ' iCell, maxLevelCell(iCell), bottomDepth(iCell): ', & + iCell, maxLevelCell(iCell), bottomDepth(iCell) + write (stderrUnit,'(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_vert_coord!}}} + +end module ocn_init + +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_sea_ice.F b/src/core_ocean/shared/mpas_ocn_sea_ice.F similarity index 92% rename from src/core_ocean/mpas_ocn_sea_ice.F rename to src/core_ocean/shared/mpas_ocn_sea_ice.F index e59ddcb61e..bb534d8e01 100644 --- a/src/core_ocean/mpas_ocn_sea_ice.F +++ b/src/core_ocean/shared/mpas_ocn_sea_ice.F @@ -12,7 +12,6 @@ !> \brief MPAS ocean sea ice formation module !> \author Doug Jacobsen !> \date 08/19/2013 -!> \version SVN:$Id:$ !> \details !> This module contains routines for the formation of sea ice. ! @@ -22,7 +21,6 @@ module ocn_sea_ice use mpas_kind_types use mpas_grid_types - use mpas_configure use mpas_timekeeping use ocn_constants @@ -65,14 +63,13 @@ module ocn_sea_ice !> \brief Performs the formation of Sea Ice within the ocean. !> \author Doug Jacobsen !> \date 08/19/2013 -!> \version SVN:$Id$ !> \details !> ocn_sea_ice_formation performs the adjustment of tracer values !> and layerThickness based on the formation of frazil ice within the ocean. ! !----------------------------------------------------------------------- - subroutine ocn_sea_ice_formation(grid, indexTemperature, indexSalinity, layerThickness, tracers, seaIceEnergy, err)!{{{ + subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, layerThickness, tracers, seaIceEnergy, err)!{{{ !----------------------------------------------------------------- ! @@ -80,7 +77,7 @@ subroutine ocn_sea_ice_formation(grid, indexTemperature, indexSalinity, layerThi ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: grid !< Input: Grid/Mesh information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information integer :: indexTemperature !< Input: Index in tracers array for temperature integer :: indexSalinity !< Input: Index in tracers array for salinity @@ -108,8 +105,9 @@ subroutine ocn_sea_ice_formation(grid, indexTemperature, indexSalinity, layerThi ! !----------------------------------------------------------------- - integer :: nCells, nVertLevels, maxLevel, nTracers, nCellsSolve + integer :: maxLevel, nTracers integer :: iCell, k, iTracer + integer, pointer :: nCells, nVertLevels, nCellsSolve integer, dimension(:), pointer :: maxLevelCell @@ -118,15 +116,18 @@ subroutine ocn_sea_ice_formation(grid, indexTemperature, indexSalinity, layerThi real (kind=RKIND) :: referenceSalinity, iceSalinity real (kind=RKIND) :: freezingTemp, density_ice real (kind=RKIND), dimension(:), allocatable :: iceTracer + real (kind=RKIND), pointer :: config_density0 if(.not. frazilFormationOn) return - nCells = grid % nCells - nCellsSolve = grid % nCellsSolve - nVertLevels = grid % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) nTracers = size(tracers, dim=1) - maxLevelCell => grid % maxLevelCell % array + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) allocate(iceTracer(nTracers)) iceTracer = 0.0_RKIND @@ -245,7 +246,6 @@ end subroutine ocn_sea_ice_formation!}}} !> \brief Computes the freezing temperature of the ocean. !> \author Doug Jacobsen !> \date 08/29/2013 -!> \version SVN:$Id$ !> \details !> This routine computes the freezing temperature of the ocean at a given !> salinity value. @@ -265,7 +265,6 @@ end function ocn_freezing_temperature!}}} !> \brief Initializes ocean sea ice module. !> \author Doug Jacobsen !> \date 08/19/2013 -!> \version SVN:$Id$ !> \details !> This routine initializes the ocean sea ice module and variables.. ! @@ -276,8 +275,13 @@ subroutine ocn_sea_ice_init(nVertLevels, err)!{{{ integer, intent(in) :: nVertLevels !< Input: Number of vertical levels suggested for level cap integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_frazil_ice_formation, config_monotonic + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_frazil_ice_formation', config_frazil_ice_formation) + call mpas_pool_get_config(ocnConfigs, 'config_monotonic', config_monotonic) + frazilFormationOn = .false. if(config_frazil_ice_formation) then diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F new file mode 100644 index 0000000000..8a7297f3bd --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -0,0 +1,602 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tendency +! +!> \brief MPAS ocean tendency driver +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date September 2011 +!> \details +!> This module contains the routines for computing +!> tendency terms for the ocean primitive equations. +! +!----------------------------------------------------------------------- + +module ocn_tendency + + use mpas_grid_types + use mpas_constants + use mpas_timer + + use ocn_constants + + use ocn_tracer_advection + use ocn_tracer_short_wave_absorption + use ocn_tracer_nonlocalflux + + use ocn_thick_hadv + use ocn_thick_vadv + use ocn_thick_surface_flux + + 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_hmix + use ocn_high_freq_thickness_hmix_del2 + use ocn_tracer_surface_flux + + implicit none + private + save + + type (timer_node), pointer :: thickHadvTimer, thickVadvTimer + type (timer_node), pointer :: velCorTimer, velVadvTimer, velPgradTimer, velHmixTimer, velForceTimer + type (timer_node), pointer :: tracerHadvTimer, tracerVadvTimer, tracerHmixTimer, tracerRestoringTimer + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tend_thick, & + ocn_tend_vel, & + ocn_tend_tracer, & + ocn_tend_freq_filtered_thickness, & + ocn_tendency_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + integer :: apply_Dhf_to_hhf, use_highFreqThick_restore + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tend_thick +! +!> \brief Computes thickness tendency +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine computes the thickness tendency for the ocean +! +!----------------------------------------------------------------------- + + subroutine ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool)!{{{ + implicit none + + type (mpas_pool_type), intent(inout) :: tendPool !< Input/Output: Tendency structure + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostics information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + + real (kind=RKIND), dimension(:), pointer :: surfaceMassFlux + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, layerThicknessEdge, & + vertAleTransportTop, tend_layerThickness, normalTransportVelocity, transmissionCoefficients + + integer :: err + + logical, pointer :: config_disable_thick_all_tend + + call mpas_timer_start("ocn_tend_thick") + + call mpas_pool_get_config(ocnConfigs, 'config_disable_thick_all_tend', config_disable_thick_all_tend) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertAleTransportTop', vertAleTransportTop) + + call mpas_pool_get_array(tendPool, 'layerThickness', tend_layerThickness) + + call mpas_pool_get_array(forcingPool, 'surfaceMassFlux', surfaceMassFlux) + call mpas_pool_get_array(forcingPool, 'transmissionCoefficients', transmissionCoefficients) + + ! + ! height tendency: start accumulating tendency terms + ! + tend_layerThickness = 0.0 + + if(config_disable_thick_all_tend) return + + ! + ! height tendency: horizontal advection term -\nabla\cdot ( hu) + ! + ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3. + ! for explanation of divergence operator. + ! + ! QC Comment (3/15/12): need to make sure that uTranport is the right + ! transport velocity here. + call mpas_timer_start("hadv", .false., thickHadvTimer) + call ocn_thick_hadv_tend(meshPool, normalTransportVelocity, layerThicknessEdge, tend_layerThickness, err) + call mpas_timer_stop("hadv", thickHadvTimer) + + ! + ! height tendency: vertical advection term -d/dz(hw) + ! + call mpas_timer_start("vadv", .false., thickVadvTimer) + call ocn_thick_vadv_tend(meshPool, vertAleTransportTop, tend_layerThickness, err) + call mpas_timer_stop("vadv", thickVadvTimer) + + ! + ! surface flux tendency + ! + call mpas_timer_start("surface flux", .false.) + + call ocn_thick_surface_flux_tend(meshPool, transmissionCoefficients, layerThickness, surfaceMassFlux, tend_layerThickness, err) + call mpas_timer_stop("surface flux") + + call mpas_timer_stop("ocn_tend_thick") + + end subroutine ocn_tend_thick!}}} + +!*********************************************************************** +! +! routine ocn_tend_vel +! +!> \brief Computes velocity tendency +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine computes the velocity tendency for the ocean +! +!----------------------------------------------------------------------- + + subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshPool, scratchPool, timeLevelIn)!{{{ + implicit none + + type (mpas_pool_type), intent(inout) :: tendPool !< Input/Output: Tendency structure + type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostic information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(inout) :: scratchPool !< Input: Scratch structure + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state fields + + real (kind=RKIND), dimension(:), pointer :: surfaceWindStress + real (kind=RKIND), dimension(:,:), pointer :: & + layerThicknessEdge, normalVelocity, tangentialVelocity, density, potentialDensity, zMid, pressure, & + tend_normalVelocity, circulation, relativeVorticity, viscosity, kineticEnergyCell, & + normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, & + montgomeryPotential, vertAleTransportTop, divergence, vertViscTopOfEdge, & + inSituThermalExpansionCoeff, inSituSalineContractionCoeff + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + integer :: timeLevel + + integer :: err + integer, pointer :: indexTemperature, indexSalinity + + logical, pointer :: config_disable_vel_all_tend + character (len=StrKIND), pointer :: config_pressure_gradient_type + + call mpas_timer_start("ocn_tend_vel") + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_all_tend', config_disable_vel_all_tend) + call mpas_pool_get_config(ocnConfigs, 'config_pressure_gradient_type', config_pressure_gradient_type) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + + call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertAleTransportTop', vertAleTransportTop) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'relativeVorticity', relativeVorticity) + call mpas_pool_get_array(diagnosticsPool, 'normalizedRelativeVorticityEdge', normalizedRelativeVorticityEdge) + call mpas_pool_get_array(diagnosticsPool, 'normalizedPlanetaryVorticityEdge', normalizedPlanetaryVorticityEdge) + call mpas_pool_get_array(diagnosticsPool, 'divergence', divergence) + call mpas_pool_get_array(diagnosticsPool, 'viscosity', viscosity) + call mpas_pool_get_array(diagnosticsPool, 'montgomeryPotential', montgomeryPotential) + call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) + call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfEdge', vertViscTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', potentialDensity) + call mpas_pool_get_array(diagnosticsPool, 'tangentialVelocity', tangentialVelocity) + + call mpas_pool_get_array(tendPool, 'normalVelocity', tend_normalVelocity) + + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + + ! + ! velocity tendency: start accumulating tendency terms + ! + tend_normalVelocity(:,:) = 0.0 + + if(config_disable_vel_all_tend) return + + ! + ! velocity tendency: nonlinear Coriolis term and grad of kinetic energy + ! + + call mpas_timer_start("coriolis", .false., velCorTimer) + call ocn_vel_coriolis_tend(meshPool, normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, layerThicknessEdge, & + normalVelocity, kineticEnergyCell, tend_normalVelocity, err) + call mpas_timer_stop("coriolis", velCorTimer) + + ! + ! velocity tendency: vertical advection term -w du/dz + ! + call mpas_timer_start("vadv", .false., velVadvTimer) + call ocn_vel_vadv_tend(meshPool, normalVelocity, layerThicknessEdge, vertAleTransportTop, tend_normalVelocity, err) + call mpas_timer_stop("vadv", velVadvTimer) + + ! + ! velocity tendency: pressure gradient + ! + call mpas_timer_start("pressure grad", .false., velPgradTimer) + if (config_pressure_gradient_type.eq.'common_level_eos') then + ! only pass EOS derivatives if needed. + call mpas_pool_get_array(diagnosticsPool, 'inSituThermalExpansionCoeff',inSituThermalExpansionCoeff) + call mpas_pool_get_array(diagnosticsPool, 'inSituSalineContractionCoeff', inSituSalineContractionCoeff) + call ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, zMid, density, potentialDensity, & + indexTemperature, indexSalinity, tracers, tend_normalVelocity, err, & + inSituThermalExpansionCoeff,inSituSalineContractionCoeff) + else + call ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, zMid, density, potentialDensity, & + indexTemperature, indexSalinity, tracers, tend_normalVelocity, err, & + inSituThermalExpansionCoeff,inSituSalineContractionCoeff) + endif + call mpas_timer_stop("pressure grad", velPgradTimer) + + ! + ! velocity tendency: del2 dissipation, \nu_2 \nabla^2 u + ! computed as \nu( \nabla divergence + k \times \nabla relativeVorticity ) + ! strictly only valid for config_mom_del2 == constant + ! + call mpas_timer_start("hmix", .false., velHmixTimer) + call ocn_vel_hmix_tend(meshPool, divergence, relativeVorticity, normalVelocity, tangentialVelocity, viscosity, & + tend_normalVelocity, scratchPool, err) + call mpas_timer_stop("hmix", velHmixTimer) + + ! + ! velocity tendency: forcing and bottom drag + ! + + call mpas_timer_start("forcings", .false., velForceTimer) + call ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceWindStress, layerThicknessEdge, tend_normalVelocity, err) + call mpas_timer_stop("forcings", velForceTimer) + + ! + ! velocity tendency: vertical mixing d/dz( nu_v du/dz)) + ! + call mpas_timer_stop("ocn_tend_vel") + + end subroutine ocn_tend_vel!}}} + +!*********************************************************************** +! +! routine ocn_tend_tracer +! +!> \brief Computes tracer tendency +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine computes tracer tendencies for the ocean +! +!----------------------------------------------------------------------- + subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, meshPool, scratchPool, dt, timeLevelIn)!{{{ + implicit none + + type (mpas_pool_type), intent(inout) :: tendPool !< Input/Output: Tendency structure + type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostic information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch information + real (kind=RKIND), intent(in) :: dt !< Input: Time step + integer, intent(in), optional :: timeLevelIn + + real (kind=RKIND), dimension(:), pointer :: penetrativeTemperatureFlux + real (kind=RKIND), dimension(:,:), pointer :: & + normalTransportVelocity, layerThickness,vertAleTransportTop, layerThicknessEdge, vertDiffTopOfCell, & + tend_layerThickness, normalThicknessFlux, surfaceTracerFlux, transmissionCoefficients, zMid, relativeSlopeTopOfEdge, & + relativeSlopeTapering, relativeSlopeTaperingCell + real (kind=RKIND), dimension(:,:,:), pointer :: & + tracers, tend_tr, vertNonLocalFlux + + integer :: err, iEdge, k + integer, pointer :: nVertLevels, nEdges, indexTemperature + integer :: timeLevel + + logical, pointer :: config_disable_tr_all_tend, config_use_cvmix_kpp + + call mpas_timer_start("ocn_tend_tracer") + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_config(ocnConfigs, 'config_disable_tr_all_tend', config_disable_tr_all_tend) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + call mpas_pool_get_array(diagnosticsPool, 'vertAleTransportTop', vertAleTransportTop) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTopOfEdge', relativeSlopeTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTapering', relativeSlopeTapering) + call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTaperingCell', relativeSlopeTaperingCell) + call mpas_pool_get_array(diagnosticsPool, 'vertNonLocalFlux', vertNonLocalFlux) + + call mpas_pool_get_array(forcingPool, 'penetrativeTemperatureFlux', penetrativeTemperatureFlux) + call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) + call mpas_pool_get_array(forcingPool, 'transmissionCoefficients', transmissionCoefficients) + + call mpas_pool_get_array(tendPool, 'tracers', tend_tr) + call mpas_pool_get_array(tendPool, 'layerThickness', tend_layerThickness) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + + ! + ! initialize tracer tendency (RHS of tracer equation) to zero. + ! + tend_tr(:,:,:) = 0.0 + + if(config_disable_tr_all_tend) return + + allocate(normalThicknessFlux(nVertLevels, nEdges+1)) + ! + ! transport velocity for the tracer. + do iEdge = 1, nEdges + do k = 1, nVertLevels + normalThicknessFlux(k, iEdge) = normalTransportVelocity(k, iEdge) * layerThicknessEdge(k, iEdge) + end do + end do + + ! + ! tracer tendency: horizontal advection term -div( layerThickness \phi u) + ! + + ! Monotonoic Advection, or standard advection + call mpas_timer_start("adv", .false., tracerHadvTimer) + call ocn_tracer_advection_tend(tracers, normalThicknessFlux, vertAleTransportTop, layerThickness, layerThickness, dt, meshPool, tend_layerThickness, tend_tr) + call mpas_timer_stop("adv", tracerHadvTimer) + + ! + ! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 \nabla \phi) + ! + call mpas_timer_start("hmix", .false., tracerHmixTimer) + call ocn_tracer_hmix_tend(meshPool, scratchPool, layerThickness, layerThicknessEdge, zMid, tracers, & + relativeSlopeTopOfEdge, relativeSlopeTapering, relativeSlopeTaperingCell, tend_tr, err) + call mpas_timer_stop("hmix", tracerHmixTimer) + + ! + ! Perform forcing from surface fluxes + ! + call mpas_timer_start("surface_flux", .false.) + call ocn_tracer_surface_flux_tend(meshPool, transmissionCoefficients, layerThickness, surfaceTracerFlux, tend_tr, err) + call mpas_timer_stop("surface_flux") + + ! + ! Performing shortwave absorption + ! + call mpas_timer_start("short wave", .false.) + call ocn_tracer_short_wave_absorption_tend(meshPool, indexTemperature, layerThickness, penetrativeTemperatureFlux, tend_tr, err) + call mpas_timer_stop("short wave") + + ! + ! Compute tracer tendency due to non-local flux computed in KPP + ! + if (config_use_cvmix_kpp) then + call mpas_timer_start("non-local flux from KPP", .false.) + call ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTracerFlux, tend_tr, err) + call mpas_timer_stop("non-local flux from KPP") + endif + + call mpas_timer_stop("ocn_tend_tracer") + + deallocate(normalThicknessFlux) + + end subroutine ocn_tend_tracer!}}} + +!*********************************************************************** +! +! routine ocn_tend_freq_filtered_thickness +! +!> \brief Compute tendencies needed for frequency filtered thickness +!> \author Mark Petersen +!> \date July 2013 +!> \details +!> This routine compute high frequency thickness tendency and the +!> low freqency divergence. It is only called when +!> config_freq_filtered_thickness is true (z-tilde) +! +!----------------------------------------------------------------------- + subroutine ocn_tend_freq_filtered_thickness(tendPool, statePool, diagnosticsPool, meshPool, timeLevelIn)!{{{ + + type (mpas_pool_type), intent(inout) :: tendPool !< Input/Output: Tendency information + type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostics information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state fields + + integer :: timeLevel + integer :: err, iCell, i, k, iEdge + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeBot, nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell, edgeSignOnCell + + real (kind=RKIND) :: flux, invAreaCell, div_hu_btr, thickness_filter_timescale_sec, highFreqThick_restore_time_sec, & + totalThickness + real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, layerThicknessEdge, & + layerThickness, & + lowFreqDivergence, highFreqThickness, & + tend_lowFreqDivergence, tend_highFreqThickness + real (kind=RKIND), dimension(:), allocatable:: div_hu + + real (kind=RKIND), pointer :: config_thickness_filter_timescale, config_highFreqThick_restore_time + + call mpas_timer_start("ocn_tend_freq_filtered_thickness") + err = 0 + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_config(ocnConfigs, 'config_thickness_filter_timescale', config_thickness_filter_timescale) + call mpas_pool_get_config(ocnConfigs, 'config_highFreqThick_restore_time', config_highFreqThick_restore_time) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergence, timeLevel) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThickness, timeLevel) + + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + + call mpas_pool_get_array(tendPool, 'lowFreqDivergence', tend_lowFreqDivergence) + call mpas_pool_get_array(tendPool, 'highFreqThickness', tend_highFreqThickness) + + allocate(div_hu(nVertLevels)) + + ! + ! Low Frequency Divergence and high frequency thickness Tendency + ! + tend_lowFreqDivergence = 0.0 + tend_highFreqThickness = 0.0 + + ! Convert restore time from days to seconds + thickness_filter_timescale_sec = config_thickness_filter_timescale*86400.0 + highFreqThick_restore_time_sec = config_highFreqThick_restore_time*86400.0 + do iCell = 1, nCells + div_hu(:) = 0.0 + div_hu_btr = 0.0 + invAreaCell = 1.0 / areaCell(iCell) + + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + + do k = 1, maxLevelEdgeBot(iEdge) + flux = layerThicknessEdge(k, iEdge) * normalVelocity(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 + + totalThickness = sum(layerThickness(1:maxLevelCell(iCell),iCell)) + do k = 1, maxLevelCell(iCell) + + tend_lowFreqDivergence(k,iCell) = & + -2.0 * pii / thickness_filter_timescale_sec & + *(lowFreqDivergence(k,iCell) - div_hu(k) & + + div_hu_btr * layerThickness(k,iCell) / totalThickness) + + tend_highFreqThickness(k,iCell) = & + - div_hu(k) + div_hu_btr * layerThickness(k,iCell) / totalThickness + lowFreqDivergence(k,iCell) & + + use_highFreqThick_restore*( -2.0 * pii / highFreqThick_restore_time_sec * highFreqThickness(k,iCell) ) + + end do + + end do + + deallocate(div_hu) + + ! + ! high frequency thickness tendency: del2 horizontal hhf diffusion, div(\kappa_{hf} \nabla h^{hf}) + ! + call mpas_timer_start("hmix", .false., tracerHmixTimer) + call ocn_high_freq_thickness_hmix_del2_tend(meshPool, highFreqThickness, tend_highFreqThickness, err) + call mpas_timer_stop("hmix", tracerHmixTimer) + + call mpas_timer_stop("ocn_tend_freq_filtered_thickness") + + end subroutine ocn_tend_freq_filtered_thickness!}}} + +!*********************************************************************** +! +! routine ocn_tendency_init +! +!> \brief Initializes flags used within tendency routines. +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date 4 November 2011 +!> \details +!> This routine initializes flags related to quantities computed within +!> other tendency routines. +! +!----------------------------------------------------------------------- + subroutine ocn_tendency_init(err)!{{{ + integer, intent(out) :: err !< Output: Error flag + + logical, pointer :: config_use_highFreqThick_restore + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_highFreqThick_restore', config_use_highFreqThick_restore) + + if (config_use_highFreqThick_restore) then + use_highFreqThick_restore = 1 + else + use_highFreqThick_restore = 0 + endif + + end subroutine ocn_tendency_init!}}} + +!*********************************************************************** + +end module ocn_tendency + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_test.F b/src/core_ocean/shared/mpas_ocn_test.F new file mode 100644 index 0000000000..750cd65968 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_test.F @@ -0,0 +1,355 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_test +! +!> \brief Driver for testing MPAS ocean core +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date October 2013 +!> \details +!> This module contains routines to test various components of +!> the MPAS ocean core. +! +!----------------------------------------------------------------------- + +module ocn_test + + use mpas_constants + use mpas_framework + use mpas_timekeeping + use mpas_dmpar + use mpas_timer + use mpas_tensor_operations + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_test_suite, & + ocn_init_gm_test_functions + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + logical :: hmixOn + type (timer_node), pointer :: del2Timer, del2TensorTimer, leithTimer, del4Timer, del4TensorTimer + + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_test_suite +! +!> \brief Call all internal start-up tests +!> \author Mark Petersen, Doug Jacobsen, Todd Ringler +!> \date October 2013 +!> \details +!> Call all routines to test various MPAS-Ocean components. +! +!----------------------------------------------------------------------- + + subroutine ocn_test_suite(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err1 + + err=0 + + call ocn_prep_test_tensor(domain,err1) + err = ior(err1,err) + + end subroutine ocn_test_suite!}}} + +!*********************************************************************** +! +! routine ocn_prep_test_tensor +! +!> \brief set up scratch variables to test strain rate and tensor divergence operators +!> \author Mark Petersen +!> \date May 2013 +!> \details +!> This routine sets up scratch variables to test strain rate and tensor divergence operators. +! +!----------------------------------------------------------------------- + + subroutine ocn_prep_test_tensor(domain,err)!{{{ + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + type (mpas_pool_type), pointer :: scratchPool, meshPool + logical, pointer :: config_test_tensors + character (len=StrKIND), pointer :: config_tensor_test_function + + type (field2DInteger), pointer :: edgeSignOnCellField + type (field2DReal), pointer :: edgeTangentVectorsField + type (field2DReal), pointer :: normalVelocityTestField + type (field2DReal), pointer :: tangentialVelocityTestField + type (field3DReal), pointer :: strainRateR3CellField + type (field3DReal), pointer :: strainRateR3CellSolutionField + type (field3DReal), pointer :: strainRateR3EdgeField + type (field3DReal), pointer :: strainRateLonLatRCellField + type (field3DReal), pointer :: strainRateLonLatRCellSolutionField + type (field3DReal), pointer :: strainRateLonLatREdgeField + type (field3DReal), pointer :: divTensorR3CellField + type (field3DReal), pointer :: divTensorR3CellSolutionField + type (field3DReal), pointer :: divTensorLonLatRCellField + type (field3DReal), pointer :: divTensorLonLatRCellSolutionField + type (field3DReal), pointer :: outerProductEdgeField + + call mpas_pool_get_config(domain % configs, 'config_test_tensors', config_test_tensors) + + if (.not.config_test_tensors) return + + call mpas_pool_get_config(domain % configs, 'config_tensor_test_function', config_tensor_test_function) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + + call mpas_pool_get_field(meshPool, 'edgeSignOnCell', edgeSignOnCellField) + call mpas_pool_get_field(meshPool, 'edgeTangentVectors', edgeTangentVectorsField) + + call mpas_pool_get_field(scratchPool, 'normalVelocityTest', normalVelocityTestField) + call mpas_pool_get_field(scratchPool, 'tangentialVelocityTest', tangentialVelocityTestField) + call mpas_pool_get_field(scratchPool, 'strainRateR3Cell', strainRateR3CellField) + call mpas_pool_get_field(scratchPool, 'strainRateR3CellSolution', strainRateR3CellSolutionField) + call mpas_pool_get_field(scratchPool, 'strainRateR3Edge', strainRateR3EdgeField) + call mpas_pool_get_field(scratchPool, 'strainRateLonLatRCell', strainRateLonLatRCellField) + call mpas_pool_get_field(scratchPool, 'strainRateLonLatRCellSolution', strainRateLonLatRCellSolutionField) + call mpas_pool_get_field(scratchPool, 'strainRateLonLatREdge', strainRateLonLatREdgeField) + call mpas_pool_get_field(scratchPool, 'divTensorR3Cell', divTensorR3CellField) + call mpas_pool_get_field(scratchPool, 'divTensorR3CellSolution', divTensorR3CellSolutionField) + call mpas_pool_get_field(scratchPool, 'divTensorLonLatRCell', divTensorLonLatRCellField) + call mpas_pool_get_field(scratchPool, 'divTensorLonLatRCellSolution', divTensorLonLatRCellSolutionField) + call mpas_pool_get_field(scratchPool, 'outerProductEdge', outerProductEdgeField) + + call mpas_allocate_scratch_field(normalVelocityTestField, .false.) + call mpas_allocate_scratch_field(tangentialVelocityTestField, .false.) + call mpas_allocate_scratch_field(strainRateR3CellField, .false.) + call mpas_allocate_scratch_field(strainRateR3CellSolutionField, .false.) + call mpas_allocate_scratch_field(strainRateR3EdgeField, .false.) + call mpas_allocate_scratch_field(strainRateLonLatRCellField, .false.) + call mpas_allocate_scratch_field(strainRateLonLatRCellSolutionField, .false.) + call mpas_allocate_scratch_field(strainRateLonLatREdgeField, .false.) + call mpas_allocate_scratch_field(divTensorR3CellField, .false.) + call mpas_allocate_scratch_field(divTensorR3CellSolutionField, .false.) + call mpas_allocate_scratch_field(divTensorLonLatRCellField, .false.) + call mpas_allocate_scratch_field(divTensorLonLatRCellSolutionField, .false.) + call mpas_allocate_scratch_field(outerProductEdgeField, .false.) + + call mpas_test_tensor(domain, config_tensor_test_function, & + edgeSignOnCellField, & + edgeTangentVectorsField, & + normalVelocityTestField, & + tangentialVelocityTestField, & + strainRateR3CellField, & + strainRateR3CellSolutionField, & + strainRateR3EdgeField, & + strainRateLonLatRCellField, & + strainRateLonLatRCellSolutionField, & + strainRateLonLatREdgeField, & + divTensorR3CellField, & + divTensorR3CellSolutionField, & + divTensorLonLatRCellField, & + divTensorLonLatRCellSolutionField, & + outerProductEdgeField ) + + call mpas_deallocate_scratch_field(normalVelocityTestField, .false.) + call mpas_deallocate_scratch_field(tangentialVelocityTestField, .false.) + call mpas_deallocate_scratch_field(strainRateR3CellField, .false.) + call mpas_deallocate_scratch_field(strainRateR3CellSolutionField, .false.) + call mpas_deallocate_scratch_field(strainRateR3EdgeField, .false.) + call mpas_deallocate_scratch_field(strainRateLonLatRCellField, .false.) + call mpas_deallocate_scratch_field(strainRateLonLatRCellSolutionField, .false.) + call mpas_deallocate_scratch_field(strainRateLonLatREdgeField, .false.) + call mpas_deallocate_scratch_field(divTensorR3CellField, .false.) + call mpas_deallocate_scratch_field(divTensorR3CellSolutionField, .false.) + call mpas_deallocate_scratch_field(divTensorLonLatRCellField, .false.) + call mpas_deallocate_scratch_field(divTensorLonLatRCellSolutionField, .false.) + call mpas_deallocate_scratch_field(outerProductEdgeField, .false.) + + err = 0 + + end subroutine ocn_prep_test_tensor!}}} + +!*********************************************************************** +! +! routine ocn_init_gm_test_functions +! +!> \brief Initialize Gent-McWilliams test functions +!> \author Mark Petersen +!> \date May 2014 +!> \details +!> For the initial temperature distribution +!> T = T_1 + T_2*y/y_{max} + T_3*z/z_{max} +!> and linear EOS with T coefficient alpha, this subroutine computes +!> the instantaneous analytic solution for: +!> - the Bolus stream function +!> - horizontal Bolus velocity +! +!----------------------------------------------------------------------- + + subroutine ocn_init_gm_test_functions(diagnosticsPool, meshPool, scratchPool)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(inout) :: diagnosticsPool !< Input: diagnostic fields derived from State + type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: k, iCell + integer, pointer :: nCells + integer, dimension(:), pointer :: maxLevelCell + + real(kind=RKIND) :: zTop, config_gm_analytic_temperature2, config_gm_analytic_temperature3, config_gm_analytic_ymax, & + config_gm_analytic_bottom_depth, L, R, c1, c2, zMax, zBot + real (kind=RKIND), pointer :: config_gravWaveSpeed_trunc, config_density0, config_standardGM_tracer_kappa, config_eos_linear_alpha + + real(kind=RKIND), dimension(:), pointer :: bottomDepth, refBottomDepthTopOfCell, yCell, yEdge + real(kind=RKIND), dimension(:,:), pointer :: yRelativeSlopeSolution, yGMStreamFuncSolution, yGMBolusVelocitySolution, zMid + + type (field2DReal), pointer :: yRelativeSlopeSolutionField, yGMStreamFuncSolutionField, yGMBolusVelocitySolutionField + + call mpas_pool_get_config(ocnConfigs, 'config_density0',config_density0) + call mpas_pool_get_config(ocnConfigs, 'config_eos_linear_alpha', config_eos_linear_alpha) + call mpas_pool_get_config(ocnConfigs, 'config_gravWaveSpeed_trunc',config_gravWaveSpeed_trunc) + call mpas_pool_get_config(ocnConfigs, 'config_standardGM_tracer_kappa',config_standardGM_tracer_kappa) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'refBottomDepthTopOfCell',refBottomDepthTopOfCell) + call mpas_pool_get_array(meshPool, 'yCell',yCell) + call mpas_pool_get_array(meshPool, 'yEdge',yEdge) + call mpas_pool_get_array(meshPool, 'bottomDepth',bottomDepth) + + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + + ! move solution variables to diagnostics pool to include them in output. + call mpas_pool_get_field(scratchPool, 'yRelativeSlopeSolution',yRelativeSlopeSolutionField) + call mpas_pool_get_field(scratchPool, 'yGMStreamFuncSolution',yGMStreamFuncSolutionField) + call mpas_pool_get_field(scratchPool, 'yGMBolusVelocitySolution',yGMBolusVelocitySolutionField) + + yRelativeSlopeSolution => yRelativeSlopeSolutionField % array + yGMStreamFuncSolution => yGMStreamFuncSolutionField % array + yGMBolusVelocitySolution => yGMBolusVelocitySolutionField % array + + ! These are flags that must match your initial conditions settings. See gm_analytic initial condition in mode_init. + config_gm_analytic_temperature2 = 10; + config_gm_analytic_temperature3 = -10; + config_gm_analytic_ymax = 500000; + config_gm_analytic_bottom_depth = 1000; + + ! zMax is associated with linear temperature profile in z + zMax = -config_gm_analytic_bottom_depth; + ! zBot is location we apply boundary conditions on the ODE for stream function. + zBot = zMax; + + L = config_gravWaveSpeed_trunc * sqrt(config_density0*zMax/gravity/config_eos_linear_alpha/config_gm_analytic_temperature3); + R = - config_standardGM_tracer_kappa * config_gm_analytic_temperature2 * zMax / config_gm_analytic_temperature3 / config_gm_analytic_ymax; + c1 = R*(1-exp(-zBot/L))/(exp(zBot/L) - exp(-zBot/L)); + c2 = R-c1; + + do iCell = 1, nCells + + do k = 1, maxLevelCell(iCell) + ! placed at mid-depth of cell center: + yGMBolusVelocitySolution(k,iCell) = 1/L*(c1*exp(zMid(k,iCell)/L) - c2*exp(-zMid(k,iCell)/L) ); + end do + + do k = 1, maxLevelCell(iCell) + ! placed at top interface, cell center. + zTop = - refBottomDepthTopOfCell(k) + yGMStreamFuncSolution(k,iCell) = c1*exp(zTop/L) + c2*exp(-zTop/L) - R; + + end do + + k = maxLevelCell(iCell)+1 + ! placed at top interface, cell center. + zTop = zBot + yGMStreamFuncSolution(k,iCell) = c1*exp(zTop/L) + c2*exp(-zTop/L) - R; + + end do + + end subroutine ocn_init_gm_test_functions!}}} + +end module ocn_test + +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_thick_ale.F b/src/core_ocean/shared/mpas_ocn_thick_ale.F similarity index 75% rename from src/core_ocean/mpas_ocn_thick_ale.F rename to src/core_ocean/shared/mpas_ocn_thick_ale.F index d11a5892f4..defcbbc910 100644 --- a/src/core_ocean/mpas_ocn_thick_ale.F +++ b/src/core_ocean/shared/mpas_ocn_thick_ale.F @@ -13,17 +13,18 @@ !> \author Mark Petersen !> \date August 2013 !> \details -!> This module contains the routines for computing -!> diagnostic variables, and other quantities such as vertTransportVelocityTop. +!> This module contains the routines for computing ALE thickness. ! !----------------------------------------------------------------------- module ocn_thick_ale use mpas_grid_types - use mpas_configure use mpas_constants use mpas_timer + use mpas_packages + + use ocn_constants implicit none private @@ -50,8 +51,6 @@ module ocn_thick_ale ! !-------------------------------------------------------------------- - integer :: use_freq_filtered_thickness - !*********************************************************************** contains @@ -70,7 +69,7 @@ module ocn_thick_ale !> (z-tilde), and imposes a minimum layer thickness. ! !----------------------------------------------------------------------- - subroutine ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreqThickness, dt, ALE_thickness, err)!{{{ + subroutine ocn_ALE_thickness(meshPool, verticalMeshPool, oldSSH, div_hu_btr, newHighFreqThickness, dt, ALE_thickness, err)!{{{ !----------------------------------------------------------------- ! @@ -78,11 +77,11 @@ subroutine ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreq ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: horizonal mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: horizonal mesh information - type (verticalMesh_type), intent(in) :: & - verticalMesh !< Input: vertical mesh information + type (mpas_pool_type), intent(in) :: & + verticalMeshPool !< Input: vertical mesh information real (kind=RKIND), dimension(:), intent(in) :: & oldSSH, &!< Input: sea surface height at old time @@ -111,7 +110,8 @@ subroutine ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreq ! !----------------------------------------------------------------- - integer :: iCell, k, i, nCells, nVertLevels, kMax + integer :: iCell, k, i, kMax + integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND) :: thicknessSum, newSSH, remainder, newThickness, thicknessWithRemainder @@ -124,15 +124,26 @@ subroutine ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreq real (kind=RKIND), dimension(:,:), pointer :: & restingThickness !> Layer thickness when the ocean is at rest, i.e. without SSH or internal perturbations. + logical, pointer :: thicknessFilterActive + logical, pointer :: config_use_min_max_thickness + real (kind=RKIND), pointer :: config_max_thickness_factor + real (kind=RKIND), pointer :: config_min_thickness + err = 0 - maxLevelCell => mesh % maxLevelCell % array - vertCoordMovementWeights => mesh % vertCoordMovementWeights % array + call mpas_pool_get_package(ocnPackages, 'thicknessFilterActive', thicknessFilterActive) - restingThickness => verticalMesh % restingThickness % array + call mpas_pool_get_config(ocnConfigs, 'config_use_min_max_thickness', config_use_min_max_thickness) + call mpas_pool_get_config(ocnConfigs, 'config_max_thickness_factor', config_max_thickness_factor) + call mpas_pool_get_config(ocnConfigs, 'config_min_thickness', config_min_thickness) - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) allocate(SSH_ALE_thickness(nVertLevels), prelim_ALE_thickness(nVertLevels), & min_ALE_thickness_down(nVertLevels), min_ALE_thickness_up(nVertLevels)) @@ -140,7 +151,7 @@ subroutine ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreq ! ! ALE thickness alteration due to SSH (z-star) ! - do iCell=1,nCells + do iCell = 1, nCells kMax = maxLevelCell(iCell) newSSH = oldSSH(iCell) - dt*div_hu_btr(iCell) @@ -154,24 +165,32 @@ subroutine ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreq ! Note that restingThickness is nonzero, and remaining terms are perturbations about zero. ALE_Thickness(1:kMax, iCell) = & restingThickness(1:kMax,iCell) & - + SSH_ALE_Thickness(1:kMax) & - + use_freq_filtered_thickness * newHighFreqThickness(1:kMax,iCell) - + + SSH_ALE_Thickness(1:kMax) enddo + if (thicknessFilterActive) then + do iCell = 1, nCells + kMax = maxLevelCell(iCell) + + ALE_Thickness(1:kMax, iCell) = & + ALE_Thickness(1:kMax, iCell) & + + newHighFreqThickness(1:kMax,iCell) + enddo + end if + ! ! ALE thickness alteration due to minimum and maximum thickness ! if (config_use_min_max_thickness) then - do iCell=1,nCells + do iCell = 1, nCells kMax = maxLevelCell(iCell) ! go down the column: prelim_ALE_Thickness(1:kMax) = ALE_Thickness(1:kMax, iCell) remainder = 0.0 do k = 1, kMax - newThickness = max(min(prelim_ALE_Thickness(k)+remainder,config_max_thickness_factor*restingThickness(k,iCell)),config_min_thickness) + newThickness = max(min(prelim_ALE_Thickness(k) + remainder, config_max_thickness_factor * restingThickness(k,iCell)), config_min_thickness) min_ALE_thickness_down(k) = newThickness - prelim_ALE_Thickness(k) remainder = remainder - min_ALE_thickness_down(k) end do @@ -179,8 +198,8 @@ subroutine ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreq ! go back up the column: min_ALE_thickness_up(kMax) = 0.0 prelim_ALE_Thickness(1:kMax) = prelim_ALE_Thickness(1:kMax) + min_ALE_thickness_down(1:kMax) - do k = kMax-1,1,-1 - newThickness = max(min(prelim_ALE_Thickness(k)+remainder,config_max_thickness_factor*restingThickness(k,iCell)),config_min_thickness) + do k = kMax-1, 1, -1 + newThickness = max(min(prelim_ALE_Thickness(k) + remainder, config_max_thickness_factor * restingThickness(k,iCell)), config_min_thickness) min_ALE_thickness_up(k) = newThickness - prelim_ALE_Thickness(k) remainder = remainder - min_ALE_thickness_up(k) end do @@ -196,7 +215,6 @@ subroutine ocn_ALE_thickness(mesh, verticalMesh, oldSSH, div_hu_btr, newHighFreq end subroutine ocn_ALE_thickness!}}} - !*********************************************************************** ! ! routine ocn_thick_ale_init @@ -214,12 +232,6 @@ subroutine ocn_thick_ale_init(err)!{{{ err = 0 - if (config_use_freq_filtered_thickness) then - use_freq_filtered_thickness = 1 - else - use_freq_filtered_thickness = 0 - endif - end subroutine ocn_thick_ale_init!}}} end module ocn_thick_ale diff --git a/src/core_ocean/mpas_ocn_thick_hadv.F b/src/core_ocean/shared/mpas_ocn_thick_hadv.F similarity index 82% rename from src/core_ocean/mpas_ocn_thick_hadv.F rename to src/core_ocean/shared/mpas_ocn_thick_hadv.F index 3d3d4c254e..8472ce4daf 100644 --- a/src/core_ocean/mpas_ocn_thick_hadv.F +++ b/src/core_ocean/shared/mpas_ocn_thick_hadv.F @@ -21,7 +21,7 @@ module ocn_thick_hadv use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -67,7 +67,7 @@ module ocn_thick_hadv ! !----------------------------------------------------------------------- - subroutine ocn_thick_hadv_tend(mesh, normalVelocity, layerThicknessEdge, tend, err)!{{{ + subroutine ocn_thick_hadv_tend(meshPool, normalVelocity, layerThicknessEdge, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -81,8 +81,8 @@ subroutine ocn_thick_hadv_tend(mesh, normalVelocity, layerThicknessEdge, tend, e real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge !< Input: thickness at edge - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -107,8 +107,8 @@ subroutine ocn_thick_hadv_tend(mesh, normalVelocity, layerThicknessEdge, tend, e ! !----------------------------------------------------------------- - integer :: iEdge, nEdges, cell1, cell2, nVertLevels, k, i - integer :: iCell, nCells + integer :: iEdge, cell1, cell2, k, i, iCell + integer, pointer :: nCells, nEdges, nVertLevels integer, dimension(:), pointer :: maxLevelEdgeBot, MaxLevelCell, nEdgesOnCell integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, edgeSignOnCell @@ -128,19 +128,19 @@ subroutine ocn_thick_hadv_tend(mesh, normalVelocity, layerThicknessEdge, tend, e if(.not.thickHadvOn) return - nEdges = mesh % nEdges - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - maxLevelCell => mesh % maxLevelCell % array - maxLevelEdgeBot => mesh % maxLevelEdgeBot % array - cellsOnEdge => mesh % cellsOnEdge % array - dvEdge => mesh % dvEdge % array - areaCell => mesh % areaCell % array + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) - nEdgesOnCell => mesh % nEdgesOnCell % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnCell => mesh % edgeSignOnCell % array + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) @@ -182,8 +182,12 @@ subroutine ocn_thick_hadv_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_disable_thick_hadv + thickHadvOn = .true. + call mpas_pool_get_config(ocnConfigs, 'config_disable_thick_hadv', config_disable_thick_hadv) + if(config_disable_thick_hadv) thickHadvOn = .false. err = 0 diff --git a/src/core_ocean/mpas_ocn_thick_surface_flux.F b/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F similarity index 83% rename from src/core_ocean/mpas_ocn_thick_surface_flux.F rename to src/core_ocean/shared/mpas_ocn_thick_surface_flux.F index d862082ddf..0f672c8471 100644 --- a/src/core_ocean/mpas_ocn_thick_surface_flux.F +++ b/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F @@ -12,7 +12,6 @@ !> \brief MPAS ocean surface fluxes for thickness !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id:$ !> \details !> This module contains the routine for computing !> tendencies for thickness from surface fluxes @@ -22,7 +21,7 @@ module ocn_thick_surface_flux use mpas_grid_types - use mpas_configure + use ocn_constants use ocn_forcing @@ -52,6 +51,7 @@ module ocn_thick_surface_flux !-------------------------------------------------------------------- logical :: surfaceMassFluxOn + real (kind=RKIND) :: refDensity !*********************************************************************** @@ -65,22 +65,21 @@ module ocn_thick_surface_flux !> \brief Computes tendency term from horizontal advection of thickness !> \author Doug Jacobsen !> \date 15 September 2011 -!> \version SVN:$Id$ !> \details !> This routine computes the horizontal advection tendency for !> thicknes based on current state and user choices of forcings. ! !----------------------------------------------------------------------- - subroutine ocn_thick_surface_flux_tend(mesh, transmissionCoefficients, layerThickness, surfaceMassFlux, tend, err)!{{{ + subroutine ocn_thick_surface_flux_tend(meshPool, transmissionCoefficients, layerThickness, surfaceMassFlux, tend, err)!{{{ !----------------------------------------------------------------- ! ! input variables ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & transmissionCoefficients !< Input: Coefficients for the transmission of surface fluxes @@ -115,7 +114,8 @@ subroutine ocn_thick_surface_flux_tend(mesh, transmissionCoefficients, layerThic ! !----------------------------------------------------------------- - integer :: iCell, nCells, k, nVertLevels + integer :: iCell, k + integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelCell integer, dimension(:,:), pointer :: cellMask @@ -125,21 +125,21 @@ subroutine ocn_thick_surface_flux_tend(mesh, transmissionCoefficients, layerThic if (.not. surfaceMassFluxOn) return - maxLevelCell => mesh % maxLevelCell % array - cellMask => mesh % cellMask % array + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellMask', cellMask) - nCells = mesh % nCells + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) do iCell = 1, nCells remainingFlux = 1.0_RKIND do k = 1, maxLevelCell(iCell) remainingFlux = remainingFlux - transmissionCoefficients(k, iCell) - tend(k, iCell) = tend(k, iCell) + cellMask(k, iCell) * (surfaceMassFlux(iCell)/config_density0) * transmissionCoefficients(k, iCell) + tend(k, iCell) = tend(k, iCell) + cellMask(k, iCell) * (surfaceMassFlux(iCell) / refDensity) * transmissionCoefficients(k, iCell) end do if(maxLevelCell(iCell) > 0 .and. remainingFlux > 0.0_RKIND) then - tend(maxLevelCell(iCell), iCell) = tend(maxLevelCell(iCell), iCell) + cellMask(maxLevelCell(iCell), iCell) * remainingFlux*surfaceMassFlux(iCell)/config_density0 + tend(maxLevelCell(iCell), iCell) = tend(maxLevelCell(iCell), iCell) + cellMask(maxLevelCell(iCell), iCell) * remainingFlux * surfaceMassFlux(iCell) / refDensity end if end do @@ -154,7 +154,6 @@ end subroutine ocn_thick_surface_flux_tend!}}} !> \brief Initializes ocean horizontal thickness surface fluxes !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id$ !> \details !> This routine initializes quantities related to thickness !> surface fluxes in the ocean. @@ -173,8 +172,18 @@ subroutine ocn_thick_surface_flux_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_disable_thick_sflux + character (len=StrKIND), pointer :: config_forcing_type + real (kind=RKIND), pointer :: config_density0 + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_disable_thick_sflux', config_disable_thick_sflux) + call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + + refDensity = config_density0 + surfaceMassFluxOn = .true. if (config_disable_thick_sflux) then diff --git a/src/core_ocean/mpas_ocn_thick_vadv.F b/src/core_ocean/shared/mpas_ocn_thick_vadv.F similarity index 84% rename from src/core_ocean/mpas_ocn_thick_vadv.F rename to src/core_ocean/shared/mpas_ocn_thick_vadv.F index efdb58e479..f1ea78866f 100644 --- a/src/core_ocean/mpas_ocn_thick_vadv.F +++ b/src/core_ocean/shared/mpas_ocn_thick_vadv.F @@ -21,7 +21,7 @@ module ocn_thick_vadv use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -67,7 +67,7 @@ module ocn_thick_vadv ! !----------------------------------------------------------------------- - subroutine ocn_thick_vadv_tend(mesh, vertTransportVelocityTop, tend, err)!{{{ + subroutine ocn_thick_vadv_tend(meshPool, vertAleTransportTop, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -76,10 +76,10 @@ subroutine ocn_thick_vadv_tend(mesh, vertTransportVelocityTop, tend, err)!{{{ !----------------------------------------------------------------- real (kind=RKIND), dimension(:,:), intent(in) :: & - vertTransportVelocityTop !< Input: vertical velocity on top layer + vertAleTransportTop !< Input: vertical velocity on top layer - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -104,7 +104,8 @@ subroutine ocn_thick_vadv_tend(mesh, vertTransportVelocityTop, tend, err)!{{{ ! !----------------------------------------------------------------- - integer :: iCell, nCells, nVertLevels, k + integer :: iCell, k + integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: MaxLevelCell !----------------------------------------------------------------- @@ -119,14 +120,14 @@ subroutine ocn_thick_vadv_tend(mesh, vertTransportVelocityTop, tend, err)!{{{ if(.not.thickVadvOn) return - maxLevelCell => mesh % maxLevelCell % array + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - do iCell=1,nCells - do k=1,maxLevelCell(iCell) - tend(k,iCell) = tend(k,iCell) + vertTransportVelocityTop(k+1,iCell) - vertTransportVelocityTop(k,iCell) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tend(k,iCell) = tend(k,iCell) + vertAleTransportTop(k+1,iCell) - vertAleTransportTop(k,iCell) end do end do @@ -159,6 +160,10 @@ subroutine ocn_thick_vadv_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_disable_thick_vadv + + call mpas_pool_get_config(ocnConfigs, 'config_disable_thick_vadv', config_disable_thick_vadv) + thickVadvOn = .true. if(config_disable_thick_vadv) thickVadvOn = .false. diff --git a/src/core_ocean/shared/mpas_ocn_time_average.F b/src/core_ocean/shared/mpas_ocn_time_average.F new file mode 100644 index 0000000000..24b5d79275 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_time_average.F @@ -0,0 +1,214 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +module ocn_time_average + + use mpas_grid_types + + implicit none + save + public + + contains + + subroutine ocn_time_average_init(averagePool)!{{{ + type (mpas_pool_type), intent(inout) :: averagePool + + real (kind=RKIND), pointer :: nAverage + + real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH + real (kind=RKIND), dimension(:,:), pointer :: & + avgNormalVelocity, avgVelocityZonal, avgVelocityMeridional, avgVertVelocityTop, & + varNormalVelocity, varVelocityZonal, varVelocityMeridional, & + avgNormalTransportVelocity, avgTransportVelocityZonal, avgTransportVelocityMeridional, avgVertTransportVelocityTop, & + avgNormalGMBolusVelocity, avgGMBolusVelocityZonal, avgGMBolusVelocityMeridional, avgVertGMBolusVelocityTop + + call mpas_pool_get_array(averagePool, 'nAverage', nAverage) + call mpas_pool_get_array(averagePool, 'avgSSH', avgSSH) + call mpas_pool_get_array(averagePool, 'varSSH', varSSH) + call mpas_pool_get_array(averagePool, 'avgNormalVelocity', avgNormalVelocity) + call mpas_pool_get_array(averagePool, 'avgVelocityZonal', avgVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgVelocityMeridional', avgVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertVelocityTop', avgVertVelocityTop) + call mpas_pool_get_array(averagePool, 'varNormalVelocity', varNormalVelocity) + call mpas_pool_get_array(averagePool, 'varVelocityZonal', varVelocityZonal) + call mpas_pool_get_array(averagePool, 'varVelocityMeridional', varVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgNormalTransportVelocity', avgNormalTransportVelocity) + call mpas_pool_get_array(averagePool, 'avgTransportVelocityZonal', avgTransportVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgTransportVelocityMeridional', avgTransportVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertTransportVelocityTop', avgVertTransportVelocityTop) + call mpas_pool_get_array(averagePool, 'avgNormalGMBolusVelocity', avgNormalGMBolusVelocity) + call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityZonal', avgGMBolusVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityMeridional', avgGMBolusVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertGMBolusVelocityTop', avgVertGMBolusVelocityTop) + + nAverage = 0 + + avgSSH = 0.0 + varSSH = 0.0 + avgNormalVelocity = 0.0 + avgVelocityZonal = 0.0 + avgVelocityMeridional = 0.0 + avgVertVelocityTop = 0.0 + varNormalVelocity = 0.0 + varVelocityZonal = 0.0 + varVelocityMeridional = 0.0 + avgNormalTransportVelocity = 0.0 + avgTransportVelocityZonal = 0.0 + avgTransportVelocityMeridional = 0.0 + avgVertTransportVelocityTop = 0.0 + avgNormalGMBolusVelocity = 0.0 + avgGMBolusVelocityZonal = 0.0 + avgGMBolusVelocityMeridional = 0.0 + avgVertGMBolusVelocityTop = 0.0 + + end subroutine ocn_time_average_init!}}} + + subroutine ocn_time_average_accumulate(averagePool, statePool, diagnosticsPool, timeLevelIn)!{{{ + type (mpas_pool_type), intent(inout) :: averagePool + type (mpas_pool_type), intent(in) :: statePool + type (mpas_pool_type), intent(in) :: diagnosticsPool + integer, intent(in), optional :: timeLevelIn + + real (kind=RKIND), pointer :: nAverage, old_nAverage + + real (kind=RKIND), dimension(:), pointer :: ssh + real (kind=RKIND), dimension(:,:), pointer :: & + velocityZonal, velocityMeridional, normalVelocity, vertVelocityTop, & + transportVelocityZonal, transportVelocityMeridional, normalTransportVelocity, vertTransportVelocityTop, & + GMBolusVelocityZonal, GMBolusVelocityMeridional, normalGMBolusVelocity, vertGMBolusVelocityTop + + real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH + real (kind=RKIND), dimension(:,:), pointer :: & + avgNormalVelocity, avgVelocityZonal, avgVelocityMeridional, avgVertVelocityTop, & + varNormalVelocity, varVelocityZonal, varVelocityMeridional, & + avgNormalTransportVelocity, avgTransportVelocityZonal, avgTransportVelocityMeridional, avgVertTransportVelocityTop, & + avgNormalGMBolusVelocity, avgGMBolusVelocityZonal, avgGMBolusVelocityMeridional, avgVertGMBolusVelocityTop + + real (kind=RKIND), dimension(:), pointer :: old_avgSSH, old_varSSH + real (kind=RKIND), dimension(:,:), pointer :: & + old_avgNormalVelocity, old_avgVelocityZonal, old_avgVelocityMeridional, old_avgVertVelocityTop, & + old_varNormalVelocity, old_varVelocityZonal, old_varVelocityMeridional, & + old_avgNormalTransportVelocity, old_avgTransportVelocityZonal, old_avgTransportVelocityMeridional, old_avgVertTransportVelocityTop, & + old_avgNormalGMBolusVelocity, old_avgGMBolusVelocityZonal, old_avgGMBolusVelocityMeridional, old_avgVertGMBolusVelocityTop + + integer :: timeLevel + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'ssh', ssh, timeLevel) + + call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) + call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity ', normalTransportVelocity) + call mpas_pool_get_array(diagnosticsPool, 'transportVelocityZonal', transportVelocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'transportVelocityMeridional', transportVelocityMeridional) + call mpas_pool_get_array(diagnosticsPool, 'vertTransportVelocityTop', vertTransportVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) + call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityZonal', GMBolusVelocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityMeridional', GMBolusVelocityMeridional) + call mpas_pool_get_array(diagnosticsPool, 'vertGMBolusVelocityTop', vertGMBolusVelocityTop) + + call mpas_pool_get_array(averagePool, 'nAverage', nAverage) + call mpas_pool_get_array(averagePool, 'avgSSH', avgSSH) + call mpas_pool_get_array(averagePool, 'varSSH', varSSH) + call mpas_pool_get_array(averagePool, 'avgNormalVelocity', avgNormalVelocity) + call mpas_pool_get_array(averagePool, 'avgVelocityZonal', avgVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgVelocityMeridional', avgVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertVelocityTop', avgVertVelocityTop) + call mpas_pool_get_array(averagePool, 'varNormalVelocity', varNormalVelocity) + call mpas_pool_get_array(averagePool, 'varVelocityZonal', varVelocityZonal) + call mpas_pool_get_array(averagePool, 'varVelocityMeridional', varVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgNormalTransportVelocity', avgNormalTransportVelocity) + call mpas_pool_get_array(averagePool, 'avgTransportVelocityZonal', avgTransportVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgTransportVelocityMeridional', avgTransportVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertTransportVelocityTop', avgVertTransportVelocityTop) + call mpas_pool_get_array(averagePool, 'avgNormalGMBolusVelocity', avgNormalGMBolusVelocity) + call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityZonal', avgGMBolusVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityMeridional', avgGMBolusVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertGMBolusVelocityTop', avgVertGMBolusVelocityTop) + + avgSSH = avgSSH + ssh + varSSH = varSSH + ssh**2 + avgNormalVelocity = avgNormalVelocity + normalVelocity + avgVelocityZonal = avgVelocityZonal + velocityZonal + avgVelocityMeridional = avgVelocityMeridional + velocityMeridional + avgVertVelocityTop = avgVertVelocityTop + vertVelocityTop + varNormalVelocity = varNormalVelocity + normalVelocity**2 + varVelocityZonal = varVelocityZonal + velocityZonal**2 + varVelocityMeridional = varVelocityMeridional + velocityMeridional**2 + avgNormalTransportVelocity = avgNormalTransportVelocity + normalTransportVelocity + avgTransportVelocityZonal = avgTransportVelocityZonal + transportVelocityZonal + avgTransportVelocityMeridional = avgTransportVelocityMeridional + transportVelocityMeridional + avgVertTransportVelocityTop = avgVertTransportVelocityTop + vertTransportVelocityTop + avgNormalGMBolusVelocity = avgNormalGMBolusVelocity + normalGMBolusVelocity + avgGMBolusVelocityZonal = avgGMBolusVelocityZonal + GMBolusVelocityZonal + avgGMBolusVelocityMeridional = avgGMBolusVelocityMeridional + GMBolusVelocityMeridional + avgVertGMBolusVelocityTop = avgVertGMBolusVelocityTop + vertGMBolusVelocityTop + + nAverage = nAverage + 1 + end subroutine ocn_time_average_accumulate!}}} + + subroutine ocn_time_average_normalize(averagePool)!{{{ + type (mpas_pool_type), intent(inout) :: averagePool + + real (kind=RKIND), pointer :: nAverage + + real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH + real (kind=RKIND), dimension(:,:), pointer :: & + avgNormalVelocity, avgVelocityZonal, avgVelocityMeridional, avgVertVelocityTop, & + varNormalVelocity, varVelocityZonal, varVelocityMeridional, & + avgNormalTransportVelocity, avgTransportVelocityZonal, avgTransportVelocityMeridional, avgVertTransportVelocityTop, & + avgNormalGMBolusVelocity, avgGMBolusVelocityZonal, avgGMBolusVelocityMeridional, avgVertGMBolusVelocityTop + + call mpas_pool_get_array(averagePool, 'nAverage', nAverage) + call mpas_pool_get_array(averagePool, 'avgSSH', avgSSH) + call mpas_pool_get_array(averagePool, 'varSSH', varSSH) + call mpas_pool_get_array(averagePool, 'avgNormalVelocity', avgNormalVelocity) + call mpas_pool_get_array(averagePool, 'avgVelocityZonal', avgVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgVelocityMeridional', avgVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertVelocityTop', avgVertVelocityTop) + call mpas_pool_get_array(averagePool, 'varNormalVelocity', varNormalVelocity) + call mpas_pool_get_array(averagePool, 'varVelocityZonal', varVelocityZonal) + call mpas_pool_get_array(averagePool, 'varVelocityMeridional', varVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgNormalTransportVelocity', avgNormalTransportVelocity) + call mpas_pool_get_array(averagePool, 'avgTransportVelocityZonal', avgTransportVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgTransportVelocityMeridional', avgTransportVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertTransportVelocityTop', avgVertTransportVelocityTop) + call mpas_pool_get_array(averagePool, 'avgNormalGMBolusVelocity', avgNormalGMBolusVelocity) + call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityZonal', avgGMBolusVelocityZonal) + call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityMeridional', avgGMBolusVelocityMeridional) + call mpas_pool_get_array(averagePool, 'avgVertGMBolusVelocityTop', avgVertGMBolusVelocityTop) + + if(nAverage > 0) then + avgSSH = avgSSH / nAverage + varSSH = varSSH / nAverage + avgNormalVelocity = avgNormalVelocity / nAverage + avgVelocityZonal = avgVelocityZonal / nAverage + avgVelocityMeridional = avgVelocityMeridional / nAverage + avgVertVelocityTop = avgVertVelocityTop / nAverage + varNormalVelocity = varNormalVelocity / nAverage + varVelocityZonal = varVelocityZonal / nAverage + varVelocityMeridional = varVelocityMeridional / nAverage + avgNormalTransportVelocity = avgNormalTransportVelocity / nAverage + avgTransportVelocityZonal = avgTransportVelocityZonal / nAverage + avgTransportVelocityMeridional = avgTransportVelocityMeridional / nAverage + avgVertTransportVelocityTop = avgVertTransportVelocityTop / nAverage + avgNormalGMBolusVelocity = avgNormalGMBolusVelocity / nAverage + avgGMBolusVelocityZonal = avgGMBolusVelocityZonal / nAverage + avgGMBolusVelocityMeridional = avgGMBolusVelocityMeridional / nAverage + avgVertGMBolusVelocityTop = avgVertGMBolusVelocityTop / nAverage + end if + end subroutine ocn_time_average_normalize!}}} + +end module ocn_time_average diff --git a/src/core_ocean/mpas_ocn_time_average_coupled.F b/src/core_ocean/shared/mpas_ocn_time_average_coupled.F similarity index 63% rename from src/core_ocean/mpas_ocn_time_average_coupled.F rename to src/core_ocean/shared/mpas_ocn_time_average_coupled.F index d83bdb467e..66a68e1080 100644 --- a/src/core_ocean/mpas_ocn_time_average_coupled.F +++ b/src/core_ocean/shared/mpas_ocn_time_average_coupled.F @@ -41,20 +41,23 @@ module ocn_time_average_coupled !> This routine initializes the coupled time averaging fields ! !----------------------------------------------------------------------- - subroutine ocn_time_average_coupled_init(forcing)!{{{ - type (forcing_type), intent(inout) :: forcing + subroutine ocn_time_average_coupled_init(forcingPool)!{{{ + type (mpas_pool_type), intent(inout) :: forcingPool real (kind=RKIND), dimension(:,:), pointer :: avgTracersSurfaceValue, avgSurfaceVelocity, avgSSHGradient - avgTracersSurfaceValue => forcing % avgTracersSurfaceValue % array - avgSurfaceVelocity => forcing % avgSurfaceVelocity % array - avgSSHGradient => forcing % avgSSHGradient % array + integer, pointer :: nAccumulatedCoupled + + call mpas_pool_get_array(forcingPool, 'avgTracersSurfaceValue', avgTracersSurfaceValue) + call mpas_pool_get_array(forcingPool, 'avgSurfaceVelocity', avgSurfaceVelocity) + call mpas_pool_get_array(forcingPool, 'avgSSHGradient', avgSSHGradient) + call mpas_pool_get_array(forcingPool, 'nAccumulatedCoupled', nAccumulatedCoupled) avgTracersSurfaceValue(:,:) = 0.0_RKIND avgSurfaceVelocity(:,:) = 0.0_RKIND avgSSHGradient(:,:) = 0.0_RKIND - forcing % nAccumulatedCoupled % scalar = 0 + nAccumulatedCoupled = 0 end subroutine ocn_time_average_coupled_init!}}} @@ -69,30 +72,30 @@ end subroutine ocn_time_average_coupled_init!}}} !> This routine accumulated the coupled time averaging fields ! !----------------------------------------------------------------------- - subroutine ocn_time_average_coupled_accumulate(diagnostics, forcing)!{{{ - type (diagnostics_type), intent(in) :: diagnostics - type (forcing_type), intent(inout) :: forcing + subroutine ocn_time_average_coupled_accumulate(diagnosticsPool, forcingPool)!{{{ + type (mpas_pool_type), intent(in) :: diagnosticsPool + type (mpas_pool_type), intent(inout) :: forcingPool real (kind=RKIND), dimension(:,:), pointer :: surfaceVelocity, avgSurfaceVelocity real (kind=RKIND), dimension(:,:), pointer :: tracersSurfaceValue, avgTracersSurfaceValue real (kind=RKIND), dimension(:,:), pointer :: avgSSHGradient real (kind=RKIND), dimension(:,:), pointer :: gradSSHZonal, gradSSHMeridional - integer :: index_temperature, index_zonalSSH, index_meridionalSSH, nAccumulatedCoupled + integer, pointer :: index_temperature, index_SSHzonal, index_SSHmeridional, nAccumulatedCoupled - tracersSurfaceValue => diagnostics % tracersSurfaceValue % array - surfaceVelocity => diagnostics % surfaceVelocity % array - gradSSHZonal => diagnostics % gradSSHZonal % array - gradSSHMeridional => diagnostics % gradSSHMeridional % array + call mpas_pool_get_array(diagnosticsPool, 'tracersSurfaceValue', tracersSurfaceValue) + call mpas_pool_get_array(diagnosticsPool, 'surfaceVelocity', surfaceVelocity) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHZonal', gradSSHZonal) + call mpas_pool_get_array(diagnosticsPool, 'gradSSHMeridional', gradSSHMeridional) - avgTracersSurfaceValue => forcing % avgTracersSurfaceValue % array - avgSurfaceVelocity => forcing % avgSurfaceVelocity % array - avgSSHGradient => forcing % avgSSHGradient % array + call mpas_pool_get_array(forcingPool, 'avgTracersSurfaceValue', avgTracersSurfaceValue) + call mpas_pool_get_array(forcingPool, 'avgSurfaceVelocity', avgSurfaceVelocity) + call mpas_pool_get_array(forcingPool, 'avgSSHGradient', avgSSHGradient) - index_temperature = forcing % index_temperatureSurfaceValue - index_zonalSSH = forcing % index_avgZonalSSHGradient - index_meridionalSSH = forcing % index_avgMeridionalSSHGradient + call mpas_pool_get_dimension(forcingPool, 'index_avgTemperatureSurfaceValue', index_temperature) + call mpas_pool_get_dimension(forcingPool, 'index_avgSSHGradientZonal', index_SSHzonal) + call mpas_pool_get_dimension(forcingPool, 'index_avgSSHGradientMeridional', index_SSHmeridional) - nAccumulatedCoupled = forcing % nAccumulatedCoupled % scalar + call mpas_pool_get_array(forcingPool, 'nAccumulatedCoupled', nAccumulatedCoupled) avgTracersSurfaceValue(:,:) = avgTracersSurfaceValue(:,:) * nAccumulatedCoupled + tracersSurfaceValue(:,:) avgTracersSurfaceValue(index_temperature,:) = avgTracersSurfaceValue(index_temperature,:) + T0_Kelvin @@ -100,10 +103,10 @@ subroutine ocn_time_average_coupled_accumulate(diagnostics, forcing)!{{{ avgSurfaceVelocity(:,:) = ( avgSurfaceVelocity(:,:) * nAccumulatedCoupled + surfaceVelocity(:,:) ) / ( nAccumulatedCoupled + 1 ) - avgSSHGradient(index_zonalSSH,:) = ( avgSSHGradient(index_zonalSSH,:) * nAccumulatedCoupled + gradSSHZonal(1,:) ) / ( nAccumulatedCoupled + 1 ) - avgSSHGradient(index_meridionalSSH,:) = ( avgSSHGradient(index_meridionalSSH,:) * nAccumulatedCoupled + gradSSHMeridional(1,:) ) / ( nAccumulatedCoupled + 1 ) + avgSSHGradient(index_SSHzonal,:) = ( avgSSHGradient(index_SSHzonal,:) * nAccumulatedCoupled + gradSSHZonal(1,:) ) / ( nAccumulatedCoupled + 1 ) + avgSSHGradient(index_SSHmeridional,:) = ( avgSSHGradient(index_SSHmeridional,:) * nAccumulatedCoupled + gradSSHMeridional(1,:) ) / ( nAccumulatedCoupled + 1 ) - forcing % nAccumulatedCoupled % scalar = forcing % nAccumulatedCoupled % scalar + 1 + nAccumulatedCoupled = nAccumulatedCoupled + 1 end subroutine ocn_time_average_coupled_accumulate!}}} @@ -118,9 +121,9 @@ end subroutine ocn_time_average_coupled_accumulate!}}} !> This routine normalizes the coupled time averaging fields ! !----------------------------------------------------------------------- - subroutine ocn_time_average_coupled_normalize(forcing)!{{{ + subroutine ocn_time_average_coupled_normalize(forcingPool)!{{{ - type (forcing_type), intent(inout) :: forcing + type (mpas_pool_type), intent(inout) :: forcingPool ! real (kind=RKIND), dimension(:,:), pointer :: avgTracersSurfaceValue, avgSurfaceVelocity, avgSSHGradient diff --git a/src/core_ocean/mpas_ocn_tracer_advection.F b/src/core_ocean/shared/mpas_ocn_tracer_advection.F similarity index 54% rename from src/core_ocean/mpas_ocn_tracer_advection.F rename to src/core_ocean/shared/mpas_ocn_tracer_advection.F index b2e6562f9d..9fbeeac9d6 100644 --- a/src/core_ocean/mpas_ocn_tracer_advection.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_advection.F @@ -23,12 +23,13 @@ module ocn_tracer_advection use mpas_kind_types use mpas_grid_types - use mpas_configure use mpas_sort use mpas_hash use mpas_tracer_advection_std use mpas_tracer_advection_mono + + use ocn_constants implicit none private @@ -54,7 +55,7 @@ module ocn_tracer_advection !> advection of tracers. ! !----------------------------------------------------------------------- - subroutine ocn_tracer_advection_tend(tracers, normalThicknessFlux, w, layerThickness, verticalCellSize, dt, mesh, tend_layerThickness, tend)!{{{ + subroutine ocn_tracer_advection_tend(tracers, normalThicknessFlux, w, layerThickness, verticalCellSize, dt, meshPool, tend_layerThickness, tend)!{{{ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: tracer tendency real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input/Output: tracer values @@ -63,21 +64,35 @@ subroutine ocn_tracer_advection_tend(tracers, normalThicknessFlux, w, layerThick real (kind=RKIND), dimension(:,:), intent(in) :: layerThickness !< Input: Thickness field real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of a cell real (kind=RKIND), intent(in) :: dt !< Input: Time step - type (mesh_type), intent(in) :: mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: tend_layerThickness !< Input: Thickness tendency information + real (kind=RKIND), dimension(:,:), pointer :: advCoefs, advCoefs3rd + + integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, nAdvCellsForEdge + integer, dimension(:,:), pointer :: highOrderAdvectionMask, edgeSignOnCell, advCellsForEdge + if(.not. tracerAdvOn) return + call mpas_pool_get_array(meshPool, 'advCoefs', advCoefs) + call mpas_pool_get_array(meshPool, 'advCoefs3rd', advCoefs3rd) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'highOrderAdvectionMask', highOrderAdvectionMask) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array(meshPool, 'advCellsForEdge', advCellsForEdge) + if(monotonicOn) then - call mpas_tracer_advection_mono_tend(tracers, mesh % advCoefs % array, mesh % advCoefs3rd % array, & - mesh % nAdvCellsForEdge % array, mesh % advCellsForEdge % array, normalThicknessFlux, w, layerThickness, & - verticalCellSize, dt, mesh, tend_layerThickness, tend, mesh % maxLevelCell % array, mesh % maxLevelEdgeTop % array, & - mesh % highOrderAdvectionMask % array, edgeSignOnCell_in = mesh % edgeSignOnCell % array) + call mpas_tracer_advection_mono_tend(tracers, advCoefs, advCoefs3rd, & + nAdvCellsForEdge, advCellsForEdge, normalThicknessFlux, w, layerThickness, & + verticalCellSize, dt, meshPool, tend_layerThickness, tend, maxLevelCell, maxLevelEdgeTop, & + highOrderAdvectionMask, edgeSignOnCell_in = edgeSignOnCell) else - call mpas_tracer_advection_std_tend(tracers, mesh % advCoefs % array, mesh % advCoefs3rd % array, & - mesh % nAdvCellsForEdge % array, mesh % advCellsForEdge % array, normalThicknessFlux, w, layerThickness, & - verticalCellSize, dt, mesh, tend_layerThickness, tend, mesh % maxLevelCell % array, mesh % maxLevelEdgeTop % array, & - mesh % highOrderAdvectionMask % array, edgeSignOnCell_in = mesh % edgeSignOnCell % array) + call mpas_tracer_advection_std_tend(tracers, advCoefs, advCoefs3rd, & + nAdvCellsForEdge, advCellsForEdge, normalThicknessFlux, w, layerThickness, & + verticalCellSize, dt, meshPool, tend_layerThickness, tend, maxLevelCell, maxLevelEdgeTop, & + highOrderAdvectionMask, edgeSignOnCell_in = edgeSignOnCell) endif end subroutine ocn_tracer_advection_tend!}}} @@ -99,14 +114,27 @@ subroutine ocn_tracer_advection_init(err)!{{{ integer :: err_tmp + logical, pointer :: config_disable_tr_adv, config_dzdk_positive, config_check_tracer_monotonicity, config_monotonic + integer, pointer :: config_horiz_tracer_adv_order, config_vert_tracer_adv_order, config_num_halos + real (kind=RKIND), pointer :: config_coef_3rd_order + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_num_halos', config_num_halos) + call mpas_pool_get_config(ocnConfigs, 'config_disable_tr_adv', config_disable_tr_adv) + call mpas_pool_get_config(ocnConfigs, 'config_dzdk_positive', config_dzdk_positive) + call mpas_pool_get_config(ocnConfigs, 'config_check_tracer_monotonicity', config_check_tracer_monotonicity) + call mpas_pool_get_config(ocnConfigs, 'config_horiz_tracer_adv_order', config_horiz_tracer_adv_order) + call mpas_pool_get_config(ocnConfigs, 'config_vert_tracer_adv_order', config_vert_tracer_adv_order) + call mpas_pool_get_config(ocnConfigs, 'config_coef_3rd_order', config_coef_3rd_order) + call mpas_pool_get_config(ocnConfigs, 'config_monotonic', config_monotonic) + tracerAdvOn = .true. if(config_disable_tr_adv) tracerAdvOn = .false. call mpas_tracer_advection_std_init(config_horiz_tracer_adv_order, config_vert_tracer_adv_order, config_coef_3rd_order, config_dzdk_positive, config_check_tracer_monotonicity, err_tmp) - call mpas_tracer_advection_mono_init(config_horiz_tracer_adv_order, config_vert_tracer_adv_order, config_coef_3rd_order, config_dzdk_positive, config_check_tracer_monotonicity, err_tmp) + call mpas_tracer_advection_mono_init(config_num_halos, config_horiz_tracer_adv_order, config_vert_tracer_adv_order, config_coef_3rd_order, config_dzdk_positive, config_check_tracer_monotonicity, err_tmp) err = ior(err, err_tmp) diff --git a/src/core_ocean/mpas_ocn_tracer_hmix.F b/src/core_ocean/shared/mpas_ocn_tracer_hmix.F similarity index 81% rename from src/core_ocean/mpas_ocn_tracer_hmix.F rename to src/core_ocean/shared/mpas_ocn_tracer_hmix.F index f953cdd88a..57f802574d 100644 --- a/src/core_ocean/mpas_ocn_tracer_hmix.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_hmix.F @@ -23,8 +23,8 @@ module ocn_tracer_hmix use mpas_grid_types - use mpas_configure use mpas_timer + use ocn_constants use ocn_tracer_hmix_del2 use ocn_tracer_hmix_del4 @@ -78,23 +78,31 @@ module ocn_tracer_hmix ! !----------------------------------------------------------------------- - subroutine ocn_tracer_hmix_tend(mesh, layerThicknessEdge, tracers, tend, err)!{{{ + subroutine ocn_tracer_hmix_tend(meshPool, scratchPool, layerThickness, layerThicknessEdge, zMid, tracers, & + relativeSlopeTopOfEdge, relativeSlopeTapering, relativeSlopeTaperingCell, tend, err)!{{{ + !----------------------------------------------------------------- ! ! input variables ! !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch information real (kind=RKIND), dimension(:,:), intent(in) :: & - layerThicknessEdge !< Input: thickness at edge - - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + layerThickness, &!< Input: thickness at cell centers + layerThicknessEdge, &!< Input: thickness at edge + zMid !< Input: Z coordinate at the center of a cell real (kind=RKIND), dimension(:,:,:), intent(in) :: & tracers !< Input: tracer quantities + real (kind=RKIND), dimension(:,:), intent(in) :: & + relativeSlopeTopOfEdge, & + relativeSlopeTapering, & + relativeSlopeTaperingCell + !----------------------------------------------------------------- ! ! input/output variables @@ -131,10 +139,11 @@ subroutine ocn_tracer_hmix_tend(mesh, layerThicknessEdge, tracers, tend, err)!{{ if(.not.tracerHmixOn) return call mpas_timer_start("del2", .false., del2Timer) - call ocn_tracer_hmix_del2_tend(mesh, layerThicknessEdge, tracers, tend, err1) + call ocn_tracer_hmix_del2_tend(meshPool, scratchPool, layerThickness, layerThicknessEdge, zMid, tracers, & + relativeSlopeTopOfEdge, relativeSlopeTapering, relativeSlopeTaperingCell, tend, err1) call mpas_timer_stop("del2", del2Timer) call mpas_timer_start("del4", .false., del4Timer) - call ocn_tracer_hmix_del4_tend(mesh, layerThicknessEdge, tracers, tend, err2) + call ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend, err2) call mpas_timer_stop("del4", del4Timer) err = ior(err1, err2) @@ -172,9 +181,13 @@ subroutine ocn_tracer_hmix_init(err)!{{{ integer :: err1, err2 + logical, pointer :: config_disable_tr_hmix + + call mpas_pool_get_config(ocnConfigs, 'config_disable_tr_hmix', config_disable_tr_hmix) + tracerHmixOn = .true. - if(config_disable_tr_hmix) tracerHmixOn = .false. + if ( config_disable_tr_hmix ) tracerHmixOn = .false. call ocn_tracer_hmix_del2_init(err1) call ocn_tracer_hmix_del4_init(err2) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_hmix_del2.F b/src/core_ocean/shared/mpas_ocn_tracer_hmix_del2.F new file mode 100644 index 0000000000..0fcefc50cf --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_hmix_del2.F @@ -0,0 +1,449 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_hmix_del2 +! +!> \brief MPAS ocean horizontal tracer mixing driver +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This module contains the main driver routine for computing +!> horizontal mixing tendencies. +!> +!> It provides an init and a tend function. Each are described below. +! +!----------------------------------------------------------------------- + +module ocn_tracer_hmix_del2 + + use mpas_grid_types + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_hmix_del2_tend, & + ocn_tracer_hmix_del2_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + logical :: del2On + logical, pointer :: config_use_standardGM + logical, pointer :: config_disable_redi_horizontal_term1 + logical, pointer :: config_disable_redi_horizontal_term2 + logical, pointer :: config_disable_redi_horizontal_term3 + real (kind=RKIND) :: eddyDiff2 + real (kind=RKIND), pointer :: config_Redi_kappa + + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_hmix_del2_tend +! +!> \brief Computes Laplacian tendency term for horizontal tracer mixing +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine computes the horizontal mixing tendency for tracers +!> based on current state using a Laplacian parameterization. +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_hmix_del2_tend(meshPool, scratchPool, layerThickness, layerThicknessEdge, zMid, tracers, & + relativeSlopeTopOfEdge, relativeSlopeTapering, relativeSlopeTaperingCell, tend, err)!{{{ + + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch information + + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThickness, &!< Input: thickness at cell centers + layerThicknessEdge, &!< Input: thickness at edge + zMid, &!< Input: Z coordinate at the center of a cell + relativeSlopeTopOfEdge, &!< Input: slope of coordinate relative to neutral surface at edges + relativeSlopeTapering, &!< Input: tapering of slope of coordinate relative to neutral surface at edges + relativeSlopeTaperingCell !< Input: tapering of slope of coordinate relative to neutral surface at cells + + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + tracers !< Input: tracer quantities + + !----------------------------------------------------------------- + ! + ! 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 :: iCell, iEdge, cell1, cell2 + integer :: i, k, iTracer, num_tracers + integer, pointer :: nCells, nVertLevels, nEdges + + integer, dimension(:,:), allocatable :: boundaryMask + + integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnCell, maxLevelCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, edgeSignOnCell + + real (kind=RKIND) :: invAreaCell1, invAreaCell2, invAreaCell, areaEdge + real (kind=RKIND) :: tracer_turb_flux, flux, s_tmp, r_tmp, h1, h2, s_tmpU, s_tmpD + + real (kind=RKIND), dimension(:), pointer :: areaCell, dvEdge, dcEdge + real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 + + real (kind=RKIND), dimension(:,:), pointer :: gradTracerEdge, gradTracerTopOfEdge, gradHTracerSlopedTopOfCell, & + dTracerdZTopOfCell, dTracerdZTopOfEdge, areaCellSum + + type (field2DReal), pointer :: gradTracerEdgeField, gradTracerTopOfEdgeField, gradHTracerSlopedTopOfCellField, dTracerdZTopOfCellField, dTracerdZTopOfEdgeField, & + areaCellSumField + + err = 0 + + if (.not.del2On) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + num_tracers = size(tracers, dim=1) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'meshScalingDel2', meshScalingDel2) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + + ! + ! compute a boundary mask to enforce insulating boundary conditions in the horizontal + ! + do iCell = 1, nCells + invAreaCell = 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 + ! \kappa_2 \nabla \phi on edge + tracer_turb_flux = tracers(iTracer, k, cell2) - tracers(iTracer, k, cell1) + + ! div(h \kappa_2 \nabla \phi) at cell center + flux = layerThicknessEdge(k, iEdge) * tracer_turb_flux * r_tmp + + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) - edgeSignOnCell(i, iCell) * flux * invAreaCell + end do + end do + + end do + end do + + ! + ! COMPUTE the extra terms arising due to mismatch between the constant coordinate surfaces and the + ! isopycnal surfaces. + ! + ! mrp note: Redi diffusion should be put in a separate subroutine + if (config_use_standardGM) then + + call mpas_pool_get_field(scratchPool, 'gradTracerEdge', gradTracerEdgeField) + call mpas_pool_get_field(scratchPool, 'gradTracerTopOfEdge', gradTracerTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'gradHTracerSlopedTopOfCell', gradHTracerSlopedTopOfCellField) + call mpas_pool_get_field(scratchPool, 'dTracerdZTopOfCell', dTracerdZTopOfCellField) + call mpas_pool_get_field(scratchPool, 'dTracerdZTopOfEdge', dTracerdZTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'areaCellSum', areaCellSumField) + + call mpas_allocate_scratch_field(gradTracerEdgeField, .true.) + call mpas_allocate_scratch_field(gradTracerTopOfEdgeField, .true.) + call mpas_allocate_scratch_field(gradHTracerSlopedTopOfCellField, .true.) + call mpas_allocate_scratch_field(dTracerdZTopOfCellField, .true.) + call mpas_allocate_scratch_field(dTracerdZTopOfEdgeField, .true.) + call mpas_allocate_scratch_field(areaCellSumField, .True.) + + gradTracerEdge => gradTracerEdgeField % array + gradTracerTopOfEdge => gradTracerTopOfEdgeField % array + gradHTracerSlopedTopOfCell => gradHTracerSlopedTopOfCellField % array + dTracerdZTopOfCell => dTracerdZTopOfCellField % array + dTracerdZTopOfEdge => dTracerdZTopOfEdgeField % array + areaCellSum => areaCellSumField % array + + gradTracerEdge = 0.0 + gradTracerTopOfEdge = 0.0 + gradHTracerSlopedTopOfCell = 0.0 + dTracerdZTopOfCell = 0.0 + dTracerdZTopOfEdge = 0.0 + + ! this is the "standard" del2 term, but forced to use config_redi_kappa + if(.not.config_disable_redi_horizontal_term1) then + do iCell = 1, nCells + invAreaCell = 1.0 / areaCell(iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + r_tmp = config_redi_kappa * dvEdge(iEdge) / dcEdge(iEdge) + + do k = 1, maxLevelEdgeTop(iEdge) + + ! this is the tapering of config_redi_kappa where abs(slope) > config_max_relative_slope + s_tmp = relativeSlopeTapering(k,iEdge) + + do iTracer = 1, num_tracers + ! \kappa_2 \nabla \phi on edge + tracer_turb_flux = tracers(iTracer, k, cell2) - tracers(iTracer, k, cell1) + + ! div(h \kappa_2 \nabla \phi) at cell center + flux = layerThicknessEdge(k, iEdge) * tracer_turb_flux * r_tmp * s_tmp + + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) - edgeSignOnCell(i, iCell) * flux * invAreaCell + end do + end do + + end do + end do + endif + + ! Compute vertical derivative of tracers at cell center and top of layer + do iTracer = 1, num_tracers + + do iCell = 1, nCells + do k = 2, maxLevelCell(iCell) + dTracerdZTopOfCell(k,iCell) = (tracers(iTracer,k-1,iCell) - tracers(iTracer,k,iCell)) / (zMid(k-1,iCell) - zMid(k,iCell)) + end do + + ! Approximation of dTracerdZTopOfCell on the top and bottom interfaces through the idea of having + ! ghost cells above the top and below the bottom layers of the same depths and tracer density. + ! Essentially, this enforces the boundary condition (d tracer)/dz = 0 at the top and bottom. + dTracerdZTopOfCell(1,iCell) = 0.0 + dTracerdZTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0 + end do + + ! Compute tracer gradient (gradTracerEdge) along the constant coordinate surface. + ! The computed variables lives at edge and mid-layer depth + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,maxLevelEdgeTop(iEdge) + gradTracerEdge(k,iEdge) = (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) + end do + end do + + ! Interpolate dTracerdZTopOfCell to edge and top of layer + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + do k = 1, maxLevelEdgeTop(iEdge) + dTracerdZTopOfEdge(k,iEdge) = 0.5 * (dTracerdZTopOfCell(k,cell1) + dTracerdZTopOfCell(k,cell2)) + end do + dTracerdZTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = 0.0 + end do + + ! Interpolate gradTracerEdge to edge and top of layer + do iEdge = 1, nEdges + do k = 2, maxLevelEdgeTop(iEdge) + h1 = layerThicknessEdge(k-1,iEdge) + h2 = layerThicknessEdge(k,iEdge) + + ! Using second-order interpolation below + gradTracerTopOfEdge(k,iEdge) = (h2 * gradTracerEdge(k-1,iEdge) + h1 * gradTracerEdge(k,iEdge)) / (h1 + h2) + end do + + ! Approximation of values on the top and bottom interfaces through the idea of having ghost cells above + ! the top and below the bottom layers of the same depths and tracer concentration. + gradTracerTopOfEdge(1,iEdge) = gradTracerEdge(1,iEdge) + gradTracerTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = gradTracerEdge(max(maxLevelEdgeTop(iEdge),1),iEdge) + end do + + ! Compute \nabla\cdot(relativeSlope d\phi/dz) + if(.not.config_disable_redi_horizontal_term2) then + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + invAreaCell1 = 1./areaCell(cell1) + invAreaCell2 = 1./areaCell(cell2) + + do k = 1, maxLevelEdgeTop(iEdge) + s_tmpU = relativeSlopeTapering(k , iEdge) * relativeSlopeTopOfEdge(k,iEdge)*dTracerdZTopOfEdge(k,iEdge) + s_tmpD = relativeSlopeTapering(k+1, iEdge) * relativeSlopeTopOfEdge(k+1,iEdge)*dTracerdZTopOfEdge(k+1,iEdge) + flux = 0.5*dvEdge(iEdge)*(s_tmpU + s_tmpD) + flux = flux * layerThicknessEdge(k, iEdge) + tend(iTracer,k,cell1) = tend(iTracer,k,cell1) + config_Redi_kappa * flux * invAreaCell1 + tend(iTracer,k,cell2) = tend(iTracer,k,cell2) - config_Redi_kappa * flux * invAreaCell2 + end do + + end do + endif + + ! Compute dz * d(relativeSlope\cdot\nabla\phi)/dz (so the dz cancel out) + gradHTracerSlopedTopOfCell = 0.0 + + ! Compute relativeSlope\cdot\nabla\phi (variable gradHTracerSlopedTopOfCell) at non-boundary edges + areaCellSum = 1.0e-34 + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + ! contribution of cell area from this edge: + areaEdge = 0.25 * dcEdge(iEdge) * dvEdge(iEdge) + + do k = 1, maxLevelEdgeTop(iEdge) + r_tmp = 2.0 * areaEdge * relativeSlopeTopOfEdge(k,iEdge) * gradTracerTopOfEdge(k,iEdge) + gradHTracerSlopedTopOfCell(k,cell1) = gradHTracerSlopedTopOfCell(k,cell1) + r_tmp + gradHTracerSlopedTopOfCell(k,cell2) = gradHTracerSlopedTopOfCell(k,cell2) + r_tmp + + areaCellSum(k,cell1) = areaCellSum(k,cell1) + areaEdge + areaCellSum(k,cell2) = areaCellSum(k,cell2) + areaEdge + + end do + end do + do iCell=1,nCells + do k = 1, maxLevelCell(iCell) + gradHTracerSlopedTopOfCell(k,iCell) = gradHTracerSlopedTopOfCell(k,iCell)/areaCellSum(k,iCell) + end do + end do + + if(.not.config_disable_redi_horizontal_term3) then + do iCell = 1, nCells + ! impose no-flux boundary conditions at top and bottom of column + gradHTracerSlopedTopOfCell(1,iCell) = 0.0 + gradHTracerSlopedTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0 + do k = 1, maxLevelCell(iCell) + s_tmp = relativeSlopeTaperingCell(k,iCell) + tend(iTracer,k,iCell) = tend(iTracer,k,iCell) + s_tmp * config_Redi_kappa * (gradHTracerSlopedTopOfCell(k,iCell) - gradHTracerSlopedTopOfCell(k+1,iCell)) + end do + end do + endif + + end do ! iTracer + + call mpas_deallocate_scratch_field(gradTracerEdgeField, .true.) + call mpas_deallocate_scratch_field(gradTracerTopOfEdgeField, .true.) + call mpas_deallocate_scratch_field(gradHTracerSlopedTopOfCellField, .true.) + call mpas_deallocate_scratch_field(dTracerdZTopOfCellField, .true.) + call mpas_deallocate_scratch_field(dTracerdZTopOfEdgeField, .true.) + + end if ! config_use_standardGM + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_hmix_del2_tend!}}} + +!*********************************************************************** +! +! routine ocn_tracer_hmix_del2_init +! +!> \brief Initializes ocean tracer horizontal mixing quantities +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine initializes a variety of quantities related to +!> Laplacian horizontal velocity mixing in the ocean. +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_hmix_del2_init(err)!{{{ + + !-------------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! call individual init routines for each parameterization + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + logical, pointer :: config_use_tracer_del2 + real (kind=RKIND), pointer :: config_tracer_del2 + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_tracer_del2', config_use_tracer_del2) + call mpas_pool_get_config(ocnConfigs, 'config_tracer_del2', config_tracer_del2) + call mpas_pool_get_config(ocnConfigs, 'config_use_standardGM',config_use_standardGM) + call mpas_pool_get_config(ocnConfigs, 'config_Redi_kappa',config_Redi_kappa) + call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term1',config_disable_redi_horizontal_term1) + call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term2',config_disable_redi_horizontal_term2) + call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term3',config_disable_redi_horizontal_term3) + + del2on = .false. + + if ( config_use_tracer_del2 ) then + if ( config_tracer_del2 > 0.0 ) then + del2On = .true. + eddyDiff2 = config_tracer_del2 + endif + endif + + if ( config_use_standardGM ) then + if ( config_Redi_kappa > 0.0 ) then + del2On = .true. + endif + endif + + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_hmix_del2_init!}}} + +!*********************************************************************** + +end module ocn_tracer_hmix_del2 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_tracer_hmix_del4.F b/src/core_ocean/shared/mpas_ocn_tracer_hmix_del4.F similarity index 82% rename from src/core_ocean/mpas_ocn_tracer_hmix_del4.F rename to src/core_ocean/shared/mpas_ocn_tracer_hmix_del4.F index 6a0c1495b3..79df028845 100644 --- a/src/core_ocean/mpas_ocn_tracer_hmix_del4.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_hmix_del4.F @@ -23,7 +23,7 @@ module ocn_tracer_hmix_del4 use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -72,7 +72,7 @@ module ocn_tracer_hmix_del4 ! !----------------------------------------------------------------------- - subroutine ocn_tracer_hmix_del4_tend(mesh, layerThicknessEdge, tracers, tend, err)!{{{ + subroutine ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -83,8 +83,8 @@ subroutine ocn_tracer_hmix_del4_tend(mesh, layerThicknessEdge, tracers, tend, er real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge !< Input: thickness at edge - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:,:), intent(in) :: & tracers !< Input: tracer quantities @@ -112,8 +112,9 @@ subroutine ocn_tracer_hmix_del4_tend(mesh, layerThicknessEdge, tracers, tend, er ! !----------------------------------------------------------------- - integer :: iEdge, nEdges, num_tracers, nVertLevels, nCells + integer :: iEdge, num_tracers integer :: iTracer, k, iCell, cell1, cell2, i + integer, pointer :: nEdges, nVertLevels, nCells integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelCell, nEdgesOnCell integer, dimension(:,:), pointer :: edgeMask, cellsOnEdge, edgesOnCell, edgeSignOnCell @@ -135,27 +136,27 @@ subroutine ocn_tracer_hmix_del4_tend(mesh, layerThicknessEdge, tracers, tend, er err = 0 - if (.not.del4On) return + if ( .not. del4On ) return - nEdges = mesh % nEdges - nCells = mesh % nCells + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) num_tracers = size(tracers, dim=1) - nVertLevels = mesh % nVertLevels - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - maxLevelCell => mesh % maxLevelCell % array - cellsOnEdge => mesh % cellsOnEdge % array + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - dcEdge => mesh % dcEdge % array - dvEdge => mesh % dvEdge % array - areaCell => mesh % areaCell % array - meshScalingDel4 => mesh % meshScalingDel4 % array + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'meshScalingDel4', meshScalingDel4) - edgeMask => mesh % edgeMask % array + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) - nEdgesOnCell => mesh % nEdgesOnCell % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnCell => mesh % edgeSignOnCell % array + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) allocate(delsq_tracer(num_tracers,nVertLevels, nCells+1)) @@ -234,7 +235,14 @@ subroutine ocn_tracer_hmix_del4_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_use_tracer_del4 + real (kind=RKIND), pointer :: config_tracer_del4 + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_tracer_del4', config_use_tracer_del4) + call mpas_pool_get_config(ocnConfigs, 'config_tracer_del4', config_tracer_del4) + del4on = .false. if ( config_tracer_del4 > 0.0 ) then @@ -242,7 +250,7 @@ subroutine ocn_tracer_hmix_del4_init(err)!{{{ eddyDiff4 = config_tracer_del4 endif - if(.not.config_use_tracer_del4) del4on = .false. + if ( .not. config_use_tracer_del4 ) del4on = .false. !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F b/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F new file mode 100644 index 0000000000..6a3eb3533c --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F @@ -0,0 +1,202 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_nonlocalflux +! +!> \brief MPAS ocean tracer non-local flux +!> \author Todd Ringler +!> \date 11/25/13 +!> \version SVN:$Id:$ +!> \details +!> This module contains the routine for computing +!> tracer tendencies due to non-local vertical fluxes computed in CVMix KPP +! +!----------------------------------------------------------------------- + +module ocn_tracer_nonlocalflux + + use mpas_grid_types + use mpas_configure + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_nonlocalflux_tend, & + ocn_tracer_nonlocalflux_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + logical :: nonLocalFluxOn + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_nonlocalflux_tend +! +!> \brief Computes tendency term due to non-local flux transport +!> \author Todd Ringler +!> \date 11/25/13 +!> \details +!> This routine computes the tendency for tracers based the vertical divergence of non-local fluxes. +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTracerFlux, tend, err)!{{{ + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + real (kind=RKIND), dimension(:,:), intent(in) :: & + surfaceTracerFlux !< Input: surface tracer fluxes + + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + vertNonLocalFlux !< Input: non-local flux of tracers defined at layer interfaces + + !----------------------------------------------------------------- + ! + ! 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 :: iCell, k, iTracer, nTracers + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: maxLevelCell + integer, dimension(:,:), pointer :: cellMask + real (kind=RKIND) :: fluxTopOfCell, fluxBottomOfCell + + err = 0 + + if (.not. nonLocalFluxOn) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + nTracers = size(tend, dim=1) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellMask', cellMask) + + do iCell = 1, nCells + do k = 2, maxLevelCell(iCell)-1 + + ! NOTE: at the moment, all tracers are based on the flux-profile used for temperature, i.e. vertNonLocalFlux(1,:,:) + do iTracer = 1, nTracers + fluxTopOfCell = surfaceTracerFlux(iTracer, iCell) * vertNonLocalFlux(1, k, iCell) + fluxBottomOfCell = surfaceTracerFlux(iTracer, iCell) * vertNonLocalFlux(1, k+1, iCell) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + cellMask(k, icell) * (fluxTopOfCell-fluxBottomOfCell) + end do + end do + + ! enforce boundary conditions at bottom of column + k = maxLevelCell(iCell) + do iTracer = 1, nTracers + fluxTopOfCell = surfaceTracerFlux(iTracer, iCell) * vertNonLocalFlux(1, k, iCell) + fluxBottomOfCell = 0.0 + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + cellMask(k, icell) * (fluxTopOfCell-fluxBottomOfCell) + end do + + ! enforce boundary conditions at top of column + k = 1 + do iTracer = 1, nTracers + fluxTopOfCell = 0.0 + fluxBottomOfCell = surfaceTracerFlux(iTracer, iCell) * vertNonLocalFlux(1, k+1, iCell) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + cellMask(k, icell) * (fluxTopOfCell-fluxBottomOfCell) + end do + + end do + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_nonlocalflux_tend!}}} + +!*********************************************************************** +! +! routine ocn_tracer_nonlocalflux_init +! +!> \brief Initializes ocean tracer nonlocal flux computation +!> \author Todd Ringler +!> \date 11/25/13 +!> \version SVN:$Id$ +!> \details +!> This routine initializes quantities related to nonlocal flux computation +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_nonlocalflux_init(err)!{{{ + + !-------------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_disable_tr_nonlocalflux, config_use_cvmix_kpp + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_disable_tr_nonlocalflux', config_disable_tr_nonlocalflux) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + + nonLocalFluxOn = .true. + + if (config_disable_tr_nonlocalflux) then + nonLocalFluxOn = .false. + end if + + if (.not.config_use_cvmix_kpp) then + nonLocalFluxOn = .false. + end if + + end subroutine ocn_tracer_nonlocalflux_init!}}} + +!*********************************************************************** + +end module ocn_tracer_nonlocalflux + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_tracer_short_wave_absorption.F b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F similarity index 85% rename from src/core_ocean/mpas_ocn_tracer_short_wave_absorption.F rename to src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F index c1afc72ace..7846fb9a6c 100644 --- a/src/core_ocean/mpas_ocn_tracer_short_wave_absorption.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F @@ -5,7 +5,6 @@ !> \brief MPAS ocean tracer short wave !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id:$ !> \details !> This module contains the routine for computing !> short wave tendencies @@ -15,7 +14,7 @@ module ocn_tracer_short_wave_absorption use mpas_grid_types - use mpas_configure + use ocn_constants use ocn_tracer_short_wave_absorption_jerlov implicit none @@ -56,13 +55,12 @@ module ocn_tracer_short_wave_absorption !> \brief Computes tendency term for surface fluxes !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id$ !> \details !> This routine computes the tendency for tracers based on surface fluxes. ! !----------------------------------------------------------------------- - subroutine ocn_tracer_short_wave_absorption_tend(mesh, index_temperature, layerThickness, penetrativeTemperatureFlux, tend, err)!{{{ + subroutine ocn_tracer_short_wave_absorption_tend(meshPool, index_temperature, layerThickness, penetrativeTemperatureFlux, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -70,8 +68,8 @@ subroutine ocn_tracer_short_wave_absorption_tend(mesh, index_temperature, layerT ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:), intent(in) :: & penetrativeTemperatureFlux !< Input: short wave heat flux @@ -105,8 +103,8 @@ subroutine ocn_tracer_short_wave_absorption_tend(mesh, index_temperature, layerT err = 0 - if(useJerlov) then - call ocn_tracer_short_wave_absorption_jerlov_tend(mesh, index_temperature, layerThickness, penetrativeTemperatureFlux, tend, err) + if ( useJerlov ) then + call ocn_tracer_short_wave_absorption_jerlov_tend(meshPool, index_temperature, layerThickness, penetrativeTemperatureFlux, tend, err) end if !-------------------------------------------------------------------- @@ -120,7 +118,6 @@ end subroutine ocn_tracer_short_wave_absorption_tend!}}} !> \brief Initializes ocean tracer surface flux quantities !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id$ !> \details !> This routine initializes quantities related to surface fluxes in the ocean. ! @@ -132,15 +129,19 @@ subroutine ocn_tracer_short_wave_absorption_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + character (len=StrKind), pointer :: config_sw_absorption_type + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_sw_absorption_type', config_sw_absorption_type) + useJerlov = .false. - if(trim(config_sw_absorption_type) .ne. 'jerlov') then + if ( trim( config_sw_absorption_type ) .ne. 'jerlov') then write(0,*) 'Incorrect option for config_sw_absorption_type. Options are: jerlov' err = 1 return - else if(trim(config_sw_absorption_type) == 'jerlov') then + else if ( trim( config_sw_absorption_type ) == 'jerlov') then useJerlov = .true. call ocn_tracer_short_wave_absorption_jerlov_init(err) end if diff --git a/src/core_ocean/mpas_ocn_tracer_short_wave_absorption_jerlov.F b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F similarity index 85% rename from src/core_ocean/mpas_ocn_tracer_short_wave_absorption_jerlov.F rename to src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F index 5462ec0712..1d4178c5e4 100644 --- a/src/core_ocean/mpas_ocn_tracer_short_wave_absorption_jerlov.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F @@ -5,7 +5,6 @@ !> \brief MPAS ocean tracer short wave !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id:$ !> \details !> This module contains the routine for computing !> short wave tendencies using Jerlov @@ -15,7 +14,7 @@ module ocn_tracer_short_wave_absorption_jerlov use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -70,13 +69,12 @@ module ocn_tracer_short_wave_absorption_jerlov !> \brief Computes tendency term for surface fluxes !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id$ !> \details !> This routine computes the tendency for tracers based on surface fluxes. ! !----------------------------------------------------------------------- - subroutine ocn_tracer_short_wave_absorption_jerlov_tend(mesh, index_temperature, layerThickness, penetrativeTemperatureFlux, tend, err)!{{{ + subroutine ocn_tracer_short_wave_absorption_jerlov_tend(meshPool, index_temperature, layerThickness, penetrativeTemperatureFlux, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -84,8 +82,8 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_tend(mesh, index_temperature, ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:), intent(in) :: & penetrativeTemperatureFlux !< Input: penetrative temperature flux through the surface @@ -117,7 +115,8 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_tend(mesh, index_temperature, ! !----------------------------------------------------------------- - integer :: iCell, nCells, k, nVertLevels + integer :: iCell, k + integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelCell @@ -125,22 +124,26 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_tend(mesh, index_temperature, real (kind=RKIND), dimension(:), pointer :: refBottomDepth real (kind=RKIND), dimension(:), allocatable :: weights + logical, pointer :: config_fixed_jerlov_weights + err = 0 - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_config(ocnConfigs, 'config_fixed_jerlov_weights', config_fixed_jerlov_weights) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - maxLevelCell => mesh % maxLevelCell % array - refBottomDepth => mesh % refBottomDepth % array + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) allocate(weights(nVertLevels+1)) weights = 0.0_RKIND weights(1) = 1.0_RKIND - if(config_fixed_jerlov_weights) then + if ( config_fixed_jerlov_weights ) then do iCell = 1, nCells depth = 0.0_RKIND - do k =1, maxLevelCell(iCell) + do k = 1, maxLevelCell(iCell) depth = depth + refBottomDepth(k) call ocn_get_jerlov_fraction(depth, weights(k+1)) @@ -150,7 +153,7 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_tend(mesh, index_temperature, else do iCell = 1, nCells depth = 0.0_RKIND - do k =1, maxLevelCell(iCell) + do k = 1, maxLevelCell(iCell) depth = depth + layerThickness(k, iCell) call ocn_get_jerlov_fraction(depth, weights(k+1)) @@ -172,7 +175,6 @@ end subroutine ocn_tracer_short_wave_absorption_jerlov_tend!}}} !> \brief Initializes ocean tracer surface flux quantities !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id$ !> \details !> This routine initializes quantities related to surface fluxes in the ocean. ! @@ -184,9 +186,13 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + character (len=StrKIND), pointer :: config_sw_absorption_type + err = 0 - if(trim(config_sw_absorption_type) .ne. 'jerlov') then + call mpas_pool_get_config(ocnConfigs, 'config_sw_absorption_type', config_sw_absorption_type) + + if ( trim( config_sw_absorption_type ) .ne. 'jerlov') then write(0,*) 'Incorrect option for config_sw_absorption_type. Options are: jerlov' err = 1 return @@ -203,7 +209,6 @@ end subroutine ocn_tracer_short_wave_absorption_jerlov_init!}}} !> \brief Initializes short wave absorption fractions !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id$ !> \details !> Computes fraction of solar short-wave flux penetrating to !> specified depth due to exponential decay in Jerlov water type. @@ -229,6 +234,8 @@ subroutine ocn_get_jerlov_fraction(depth, weight)!{{{ integer, parameter :: num_water_types = 5 ! max number of different water types real (kind=RKIND), parameter :: depth_cutoff = -200.0_RKIND + + integer, pointer :: config_jerlov_water_type !----------------------------------------------------------------------- ! @@ -236,6 +243,8 @@ subroutine ocn_get_jerlov_fraction(depth, weight)!{{{ ! !----------------------------------------------------------------------- + call mpas_pool_get_config(ocnConfigs, 'config_jerlov_water_type', config_jerlov_water_type) + if (-depth < depth_cutoff) then weight = 0.0_RKIND else diff --git a/src/core_ocean/mpas_ocn_tracer_surface_flux.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux.F similarity index 85% rename from src/core_ocean/mpas_ocn_tracer_surface_flux.F rename to src/core_ocean/shared/mpas_ocn_tracer_surface_flux.F index 4be9e52363..9ac3c5929f 100644 --- a/src/core_ocean/mpas_ocn_tracer_surface_flux.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux.F @@ -12,7 +12,6 @@ !> \brief MPAS ocean tracer surface flux !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id:$ !> \details !> This module contains the routine for computing !> surface flux tendencies. @@ -22,8 +21,8 @@ module ocn_tracer_surface_flux use mpas_grid_types - use mpas_configure + use ocn_constants use ocn_forcing implicit none @@ -64,21 +63,20 @@ module ocn_tracer_surface_flux !> \brief Computes tendency term for surface fluxes !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id$ !> \details !> This routine computes the tendency for tracers based on surface fluxes. ! !----------------------------------------------------------------------- - subroutine ocn_tracer_surface_flux_tend(mesh, transmissionCoefficients, layerThickness, surfaceTracerFlux, tend, err)!{{{ + subroutine ocn_tracer_surface_flux_tend(meshPool, transmissionCoefficients, layerThickness, surfaceTracerFlux, tend, err)!{{{ !----------------------------------------------------------------- ! ! input variables ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & layerThickness !< Input: Layer thickness @@ -112,7 +110,8 @@ subroutine ocn_tracer_surface_flux_tend(mesh, transmissionCoefficients, layerThi ! !----------------------------------------------------------------- - integer :: iCell, nCells, k, iTracer, nTracers, nVertLevels + integer :: iCell, k, iTracer, nTracers + integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelCell integer, dimension(:,:), pointer :: cellMask @@ -122,12 +121,12 @@ subroutine ocn_tracer_surface_flux_tend(mesh, transmissionCoefficients, layerThi if (.not. surfaceTracerFluxOn) return - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) nTracers = size(tend, dim=1) - maxLevelCell => mesh % maxLevelCell % array - cellMask => mesh % cellMask % array + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellMask', cellMask) do iCell = 1, nCells remainingFlux = 1.0_RKIND @@ -157,7 +156,6 @@ end subroutine ocn_tracer_surface_flux_tend!}}} !> \brief Initializes ocean tracer surface flux quantities !> \author Doug Jacobsen !> \date 12/17/12 -!> \version SVN:$Id$ !> \details !> This routine initializes quantities related to surface fluxes in the ocean. ! @@ -169,8 +167,14 @@ subroutine ocn_tracer_surface_flux_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_disable_tr_sflux + character (len=StrKIND), pointer :: config_forcing_type + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_disable_tr_sflux', config_disable_tr_sflux) + call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) + surfaceTracerFluxOn = .true. if (config_disable_tr_sflux) then diff --git a/src/core_ocean/mpas_ocn_vel_coriolis.F b/src/core_ocean/shared/mpas_ocn_vel_coriolis.F similarity index 78% rename from src/core_ocean/mpas_ocn_vel_coriolis.F rename to src/core_ocean/shared/mpas_ocn_vel_coriolis.F index 3d1e4f74b4..b28c61977c 100644 --- a/src/core_ocean/mpas_ocn_vel_coriolis.F +++ b/src/core_ocean/shared/mpas_ocn_vel_coriolis.F @@ -22,7 +22,7 @@ module ocn_vel_coriolis use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -69,7 +69,7 @@ module ocn_vel_coriolis ! !----------------------------------------------------------------------- - subroutine ocn_vel_coriolis_tend(mesh, normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, layerThicknessEdge, normalVelocity, kineticEnergyCell, tend, err)!{{{ + subroutine ocn_vel_coriolis_tend(meshPool, normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, layerThicknessEdge, normalVelocity, kineticEnergyCell, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -84,8 +84,8 @@ subroutine ocn_vel_coriolis_tend(mesh, normalizedRelativeVorticityEdge, normaliz normalVelocity,& !< Input: Horizontal velocity kineticEnergyCell !< Input: Kinetic Energy - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -116,31 +116,31 @@ subroutine ocn_vel_coriolis_tend(mesh, normalizedRelativeVorticityEdge, normaliz real (kind=RKIND), dimension(:), pointer :: dcEdge integer :: j, k - integer :: cell1, cell2, nEdgesSolve, iEdge, eoe + integer :: cell1, cell2, iEdge, eoe + integer, pointer :: nEdgesSolve real (kind=RKIND) :: workVorticity, q, invLength err = 0 - if(.not.coriolisOn) return + if ( .not. coriolisOn ) return - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - nEdgesOnEdge => mesh % nEdgesOnEdge % array - cellsOnEdge => mesh % cellsOnEdge % array - edgesOnEdge => mesh % edgesOnEdge % array - weightsOnEdge => mesh % weightsOnEdge % array - dcEdge => mesh % dcEdge % array + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(meshPool, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) - edgeMask => mesh % edgeMask % array + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - nEdgesSolve = mesh % nEdgesSolve - - do iEdge=1,mesh % nEdgesSolve + do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - invLength = 1.0 / dcEdge(iEdgE) + invLength = 1.0 / dcEdge(iEdge) - do k=1,maxLevelEdgeTop(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) q = 0.0 do j = 1,nEdgesOnEdge(iEdge) @@ -187,17 +187,23 @@ subroutine ocn_vel_coriolis_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_disable_vel_coriolis + character (len=StrKIND), pointer :: config_time_integrator + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_coriolis', config_disable_vel_coriolis) + call mpas_pool_get_config(ocnConfigs, 'config_time_integrator', config_time_integrator) + coriolisOn = .true. - if(config_disable_vel_coriolis) coriolisOn = .false. + if ( config_disable_vel_coriolis ) coriolisOn = .false. - if (trim(config_time_integrator) == 'RK4') then + if ( trim( config_time_integrator ) == 'RK4') then ! For RK4, coriolis tendency term includes f: (eta+f)/h. RK4On = 1 - elseif (trim(config_time_integrator) == 'split_explicit' & - .or.trim(config_time_integrator) == 'unsplit_explicit') then + elseif ( trim( config_time_integrator ) == 'split_explicit' & + .or. trim( config_time_integrator ) == 'unsplit_explicit') then ! For split explicit, Coriolis tendency uses eta/h because the Coriolis term ! is added separately to the momentum tendencies. RK4On = 0 diff --git a/src/core_ocean/mpas_ocn_vel_forcing.F b/src/core_ocean/shared/mpas_ocn_vel_forcing.F similarity index 92% rename from src/core_ocean/mpas_ocn_vel_forcing.F rename to src/core_ocean/shared/mpas_ocn_vel_forcing.F index 7397290233..06336b4998 100644 --- a/src/core_ocean/mpas_ocn_vel_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing.F @@ -21,8 +21,8 @@ module ocn_vel_forcing use mpas_grid_types - use mpas_configure + use ocn_constants use ocn_forcing use ocn_vel_forcing_windstress @@ -75,7 +75,7 @@ module ocn_vel_forcing ! !----------------------------------------------------------------------- - subroutine ocn_vel_forcing_tend(mesh, normalVelocity, surfaceWindStress, layerThicknessEdge, tend, err)!{{{ + subroutine ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceWindStress, layerThicknessEdge, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -92,8 +92,8 @@ subroutine ocn_vel_forcing_tend(mesh, normalVelocity, surfaceWindStress, layerTh real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge !< Input: thickness at edge - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -128,8 +128,8 @@ subroutine ocn_vel_forcing_tend(mesh, normalVelocity, surfaceWindStress, layerTh ! !----------------------------------------------------------------- - call ocn_vel_forcing_windstress_tend(mesh, surfaceWindStress, layerThicknessEdge, tend, err1) - call ocn_vel_forcing_rayleigh_tend(mesh, normalVelocity, tend, err2) + call ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThicknessEdge, tend, err1) + call ocn_vel_forcing_rayleigh_tend(meshPool, normalVelocity, tend, err2) err = ior(err1, err2) diff --git a/src/core_ocean/mpas_ocn_vel_forcing_rayleigh.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_rayleigh.F similarity index 83% rename from src/core_ocean/mpas_ocn_vel_forcing_rayleigh.F rename to src/core_ocean/shared/mpas_ocn_vel_forcing_rayleigh.F index 1128338f84..f5ab636195 100644 --- a/src/core_ocean/mpas_ocn_vel_forcing_rayleigh.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_rayleigh.F @@ -21,7 +21,7 @@ module ocn_vel_forcing_rayleigh use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -69,7 +69,7 @@ module ocn_vel_forcing_rayleigh ! !----------------------------------------------------------------------- - subroutine ocn_vel_forcing_rayleigh_tend(mesh, normalVelocity, tend, err)!{{{ + subroutine ocn_vel_forcing_rayleigh_tend(meshPool, normalVelocity, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -80,8 +80,8 @@ subroutine ocn_vel_forcing_rayleigh_tend(mesh, normalVelocity, tend, err)!{{{ real (kind=RKIND), dimension(:,:), intent(in) :: & normalVelocity !< Input: velocity - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -106,7 +106,8 @@ subroutine ocn_vel_forcing_rayleigh_tend(mesh, normalVelocity, tend, err)!{{{ ! !----------------------------------------------------------------- - integer :: iEdge, nEdgesSolve, k + integer :: iEdge, k + integer, pointer :: nEdgesSolve integer, dimension(:), pointer :: maxLevelEdgeTop !----------------------------------------------------------------- @@ -119,13 +120,13 @@ subroutine ocn_vel_forcing_rayleigh_tend(mesh, normalVelocity, tend, err)!{{{ err = 0 - if(.not.rayleighFrictionOn) return + if ( .not. rayleighFrictionOn ) return - nEdgesSolve = mesh % nEdgesSolve - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) - do iEdge=1,nEdgesSolve - do k=1,maxLevelEdgeTop(iEdge) + do iEdge = 1, nEdgesSolve + do k = 1, maxLevelEdgeTop(iEdge) tend(k,iEdge) = tend(k,iEdge) - rayleighDampingCoef * normalVelocity(k,iEdge) @@ -162,14 +163,19 @@ subroutine ocn_vel_forcing_rayleigh_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_Rayleigh_friction + real (kind=RKIND), pointer :: config_Rayleigh_damping_coeff err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_Rayleigh_friction', config_Rayleigh_friction) + call mpas_pool_get_config(ocnConfigs, 'config_Rayleigh_damping_coeff', config_Rayleigh_damping_coeff) + rayleighDampingCoef = 0.0 - if (config_rayleigh_friction) then + if (config_Rayleigh_friction) then rayleighFrictionOn = .true. - rayleighDampingCoef = config_rayleigh_damping_coeff + rayleighDampingCoef = config_Rayleigh_damping_coeff endif !-------------------------------------------------------------------- diff --git a/src/core_ocean/mpas_ocn_vel_forcing_windstress.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F similarity index 80% rename from src/core_ocean/mpas_ocn_vel_forcing_windstress.F rename to src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F index 5c8f274955..b3c6ffea09 100644 --- a/src/core_ocean/mpas_ocn_vel_forcing_windstress.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F @@ -21,8 +21,8 @@ module ocn_vel_forcing_windstress use mpas_grid_types - use mpas_configure + use ocn_constants use ocn_forcing implicit none @@ -69,7 +69,7 @@ module ocn_vel_forcing_windstress ! !----------------------------------------------------------------------- - subroutine ocn_vel_forcing_windstress_tend(mesh, surfaceWindStress, layerThicknessEdge, tend, err)!{{{ + subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThicknessEdge, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -83,8 +83,8 @@ subroutine ocn_vel_forcing_windstress_tend(mesh, surfaceWindStress, layerThickne real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge !< Input: thickness at edge - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -109,12 +109,15 @@ subroutine ocn_vel_forcing_windstress_tend(mesh, surfaceWindStress, layerThickne ! !----------------------------------------------------------------- - integer :: iEdge, nEdgesSolve, k + integer :: iEdge, k + integer, pointer :: nEdgesSolve integer, dimension(:), pointer :: maxLevelEdgeTop integer, dimension(:,:), pointer :: edgeMask real (kind=RKIND) :: transmissionCoeffTop, transmissionCoeffBot, zTop, zBot, remainingStress + real (kind=RKIND), pointer :: config_density0 + !----------------------------------------------------------------- ! ! call relevant routines for computing tendencies @@ -125,32 +128,37 @@ subroutine ocn_vel_forcing_windstress_tend(mesh, surfaceWindStress, layerThickne err = 0 - if(.not.windStressOn) return + if ( .not. windStressOn ) return + + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - nEdgesSolve = mesh % nEdgesSolve - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - edgeMask => mesh % edgeMask % array + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) - do iEdge=1,nEdgesSolve + do iEdge = 1, nEdgesSolve zTop = 0.0_RKIND transmissionCoeffTop = ocn_forcing_transmission(zTop) remainingStress = 1.0_RKIND - do k = 1,maxLevelEdgeTop(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) zBot = zTop - layerThicknessEdge(k, iEdge) transmissionCoeffBot = ocn_forcing_transmission(zBot) remainingStress = remainingStress - (transmissionCoeffTop - transmissionCoeffBot) - tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * surfaceWindStress(iEdge) * (transmissionCoeffTop - transmissionCoeffBot) / config_density0 / layerThicknessEdge(k,iEdge) + tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * surfaceWindStress(iEdge) & + * (transmissionCoeffTop - transmissionCoeffBot) / config_density0 / layerThicknessEdge(k,iEdge) zTop = zBot transmissionCoeffTop = transmissionCoeffBot enddo if ( maxLevelEdgeTop(iEdge) > 0 .and. remainingStress > 0.0_RKIND) then - tend(maxLevelEdgeTop(iEdge), iEdge) = tend(maxLevelEdgeTop(iEdge), iEdge) + edgeMask(maxLevelEdgeTop(iEdge), iEdge) * surfaceWindStress(iEdge) * remainingStress & - / config_density0 / layerThicknessEdge(maxLevelEdgeTop(iEdge), iEdge) + tend(maxLevelEdgeTop(iEdge), iEdge) = tend(maxLevelEdgeTop(iEdge), iEdge) & + + edgeMask(maxLevelEdgeTop(iEdge), iEdge) * surfaceWindStress(iEdge) * remainingStress & + / config_density0 / layerThicknessEdge(maxLevelEdgeTop(iEdge), iEdge) end if enddo @@ -184,6 +192,12 @@ subroutine ocn_vel_forcing_windstress_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_disable_vel_windstress + character (len=StrKIND), pointer :: config_forcing_type + + call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_windstress', config_disable_vel_windstress) + call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) + windStressOn = .true. if(config_disable_vel_windstress) windStressOn = .false. diff --git a/src/core_ocean/mpas_ocn_vel_hmix.F b/src/core_ocean/shared/mpas_ocn_vel_hmix.F similarity index 86% rename from src/core_ocean/mpas_ocn_vel_hmix.F rename to src/core_ocean/shared/mpas_ocn_vel_hmix.F index eb8529df2b..b5d0c708b9 100644 --- a/src/core_ocean/mpas_ocn_vel_hmix.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix.F @@ -23,11 +23,11 @@ module ocn_vel_hmix use mpas_grid_types - use mpas_configure use mpas_timer use ocn_vel_hmix_del2 use ocn_vel_hmix_leith use ocn_vel_hmix_del4 + use ocn_constants implicit none private @@ -79,8 +79,8 @@ module ocn_vel_hmix ! !----------------------------------------------------------------------- - subroutine ocn_vel_hmix_tend(mesh, divergence, relativeVorticity, normalVelocity, tangentialVelocity, viscosity, & - tend, scratch, err)!{{{ + subroutine ocn_vel_hmix_tend(meshPool, divergence, relativeVorticity, normalVelocity, tangentialVelocity, viscosity, & + tend, scratchPool, err)!{{{ !----------------------------------------------------------------- ! @@ -88,8 +88,8 @@ subroutine ocn_vel_hmix_tend(mesh, divergence, relativeVorticity, normalVelocity ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & divergence !< Input: velocity divergence @@ -115,8 +115,8 @@ subroutine ocn_vel_hmix_tend(mesh, divergence, relativeVorticity, normalVelocity real (kind=RKIND), dimension(:,:), intent(inout) :: & tend !< Input/Output: velocity tendency - type (scratch_type), intent(inout) :: & - scratch !< Input: Scratch structure + type (mpas_pool_type), intent(inout) :: & + scratchPool !< Input: Scratch structure !----------------------------------------------------------------- ! @@ -148,27 +148,27 @@ subroutine ocn_vel_hmix_tend(mesh, divergence, relativeVorticity, normalVelocity err = 0 call mpas_timer_start("del2", .false., del2Timer) - call ocn_vel_hmix_del2_tend(mesh, divergence, relativeVorticity, viscosity, tend, err1) + call ocn_vel_hmix_del2_tend(meshPool, divergence, relativeVorticity, viscosity, tend, err1) call mpas_timer_stop("del2", del2Timer) err = ior(err1, err) call mpas_timer_start("del2_tensor", .false., del2TensorTimer) - call ocn_vel_hmix_del2_tensor_tend(mesh, normalVelocity, tangentialVelocity, viscosity, scratch, tend, err1) + call ocn_vel_hmix_del2_tensor_tend(meshPool, normalVelocity, tangentialVelocity, viscosity, scratchPool, tend, err1) call mpas_timer_stop("del2_tensor", del2TensorTimer) err = ior(err1, err) call mpas_timer_start("leith", .false., leithTimer) - call ocn_vel_hmix_leith_tend(mesh, divergence, relativeVorticity, viscosity, tend, err1) + call ocn_vel_hmix_leith_tend(meshPool, divergence, relativeVorticity, viscosity, tend, err1) call mpas_timer_stop("leith", leithTimer) err = ior(err1, err) call mpas_timer_start("del4", .false., del4Timer) - call ocn_vel_hmix_del4_tend(mesh, divergence, relativeVorticity, tend, err1) + call ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, err1) call mpas_timer_stop("del4", del4Timer) err = ior(err1, err) call mpas_timer_start("del4_tensor", .false., del4TensorTimer) - call ocn_vel_hmix_del4_tensor_tend(mesh, normalVelocity, tangentialVelocity, viscosity, scratch, tend, err1) + call ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVelocity, viscosity, scratchPool, tend, err1) call mpas_timer_stop("del4_tensor", del4TensorTimer) err = ior(err1, err) @@ -205,6 +205,10 @@ subroutine ocn_vel_hmix_init(err)!{{{ integer :: err1, err2, err3 + logical, pointer :: config_disable_vel_hmix + + call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_hmix', config_disable_vel_hmix) + hmixOn = .true. call ocn_vel_hmix_del2_init(err1) diff --git a/src/core_ocean/mpas_ocn_vel_hmix_del2.F b/src/core_ocean/shared/mpas_ocn_vel_hmix_del2.F similarity index 67% rename from src/core_ocean/mpas_ocn_vel_hmix_del2.F rename to src/core_ocean/shared/mpas_ocn_vel_hmix_del2.F index 0ff3c12c80..d8e27101c3 100644 --- a/src/core_ocean/mpas_ocn_vel_hmix_del2.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix_del2.F @@ -21,10 +21,10 @@ module ocn_vel_hmix_del2 use mpas_grid_types - use mpas_configure use mpas_vector_operations use mpas_matrix_operations use mpas_tensor_operations + use ocn_constants implicit none private @@ -75,7 +75,7 @@ module ocn_vel_hmix_del2 ! !----------------------------------------------------------------------- - subroutine ocn_vel_hmix_del2_tend(mesh, divergence, relativeVorticity, viscosity, tend, err)!{{{ + subroutine ocn_vel_hmix_del2_tend(meshPool, divergence, relativeVorticity, viscosity, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -89,12 +89,12 @@ subroutine ocn_vel_hmix_del2_tend(mesh, divergence, relativeVorticity, viscosity real (kind=RKIND), dimension(:,:), intent(in) :: & relativeVorticity !< Input: relative vorticity - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information - - !----------------------------------------------------------------- - ! - ! input/output variables + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + !------ ----------------------------------------------------------- + ! + ! input /output variables ! !----------------------------------------------------------------- @@ -118,7 +118,8 @@ subroutine ocn_vel_hmix_del2_tend(mesh, divergence, relativeVorticity, viscosity ! !----------------------------------------------------------------- - integer :: iEdge, nEdgesSolve, cell1, cell2, vertex1, vertex2, k + integer :: iEdge, cell1, cell2, vertex1, vertex2, k + integer, pointer :: nEdgesSolve integer, dimension(:), pointer :: maxLevelEdgeTop integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask @@ -126,6 +127,8 @@ subroutine ocn_vel_hmix_del2_tend(mesh, divergence, relativeVorticity, viscosity real (kind=RKIND), dimension(:), pointer :: meshScalingDel2, & dcEdge, dvEdge + real (kind=RKIND), pointer :: config_mom_del2 + !----------------------------------------------------------------- ! ! exit if this mixing is not selected @@ -136,16 +139,19 @@ subroutine ocn_vel_hmix_del2_tend(mesh, divergence, relativeVorticity, viscosity if(.not.hmixDel2On) return - nEdgesSolve = mesh % nEdgesSolve - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - cellsOnEdge => mesh % cellsOnEdge % array - verticesOnEdge => mesh % verticesOnEdge % array - meshScalingDel2 => mesh % meshScalingDel2 % array - edgeMask => mesh % edgeMask % array - dcEdge => mesh % dcEdge % array - dvEdge => mesh % dvEdge % array + call mpas_pool_get_config(ocnConfigs, 'config_mom_del2', config_mom_del2) - do iEdge=1,nEdgesSolve + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + + do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) vertex1 = verticesOnEdge(1,iEdge) @@ -154,7 +160,7 @@ subroutine ocn_vel_hmix_del2_tend(mesh, divergence, relativeVorticity, viscosity invLength1 = 1.0 / dcEdge(iEdge) invLength2 = 1.0 / dvEdge(iEdge) - do k=1,maxLevelEdgeTop(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) ! Here -( relativeVorticity(k,vertex2) - relativeVorticity(k,vertex1) ) / dvEdge(iEdge) ! is - \nabla relativeVorticity pointing from vertex 2 to vertex 1, or equivalently @@ -191,7 +197,7 @@ end subroutine ocn_vel_hmix_del2_tend!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vel_hmix_del2_tensor_tend(mesh, normalVelocity, tangentialVelocity, viscosity, scratch, tend, err)!{{{ + subroutine ocn_vel_hmix_del2_tensor_tend(meshPool, normalVelocity, tangentialVelocity, viscosity, scratchPool, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -205,8 +211,8 @@ subroutine ocn_vel_hmix_del2_tensor_tend(mesh, normalVelocity, tangentialVelocit real (kind=RKIND), dimension(:,:), intent(in) :: & tangentialVelocity !< Input: velocity, tangent to an edge - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -217,8 +223,8 @@ subroutine ocn_vel_hmix_del2_tensor_tend(mesh, normalVelocity, tangentialVelocit real (kind=RKIND), dimension(:,:), intent(inout) :: & viscosity !< Input/Output: viscosity - type (scratch_type), intent(inout) :: & - scratch !< Input/Output: Scratch structure + type (mpas_pool_type), intent(inout) :: & + scratchPool !< Input/Output: Scratch structure real (kind=RKIND), dimension(:,:), intent(inout) :: & tend !< Input/Output: velocity tendency @@ -237,7 +243,8 @@ subroutine ocn_vel_hmix_del2_tensor_tend(mesh, normalVelocity, tangentialVelocit ! !----------------------------------------------------------------- - integer :: iEdge, nEdgesSolve, nEdges, k, nVertLevels + integer :: iEdge, k + integer, pointer :: nEdgesSolve, nEdges, nVertLevels integer, dimension(:), pointer :: maxLevelEdgeTop integer, dimension(:,:), pointer :: edgeMask, edgeSignOnCell @@ -247,6 +254,12 @@ subroutine ocn_vel_hmix_del2_tensor_tend(mesh, normalVelocity, tangentialVelocit real (kind=RKIND), dimension(:,:,:), pointer :: & strainRateR3Cell, strainRateR3Edge, divTensorR3Cell, outerProductEdge + type (field2DReal), pointer :: normalVectorEdgeField + type (field3DReal), pointer :: strainRateR3CellField, strainRateR3EdgeField, divTensorR3CellField, outerProductEdgeField + + logical, pointer :: config_use_mom_del2_tensor + real (kind=RKIND), pointer :: config_mom_del2_tensor + !----------------------------------------------------------------- ! ! exit if this mixing is not selected @@ -254,66 +267,76 @@ subroutine ocn_vel_hmix_del2_tensor_tend(mesh, normalVelocity, tangentialVelocit !----------------------------------------------------------------- err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_use_mom_del2_tensor', config_use_mom_del2_tensor) - if (.not.config_use_mom_del2_tensor) return - - nEdges = mesh % nEdges - nVertLevels = mesh % nVertLevels - nEdgesSolve = mesh % nEdgesSolve - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - meshScalingDel2 => mesh % meshScalingDel2 % array - edgeMask => mesh % edgeMask % array - edgeSignOnCell => mesh % edgeSignOnCell % array - edgeTangentVectors => mesh % edgeTangentVectors % array - - call mpas_allocate_scratch_field(scratch % strainRateR3Cell, .true.) - call mpas_allocate_scratch_field(scratch % strainRateR3Edge, .true.) - call mpas_allocate_scratch_field(scratch % divTensorR3Cell, .true.) - call mpas_allocate_scratch_field(scratch % outerProductEdge, .true.) - call mpas_allocate_scratch_field(scratch % normalVectorEdge, .true.) - - strainRateR3Cell => scratch % strainRateR3Cell % array - strainRateR3Edge => scratch % strainRateR3Edge % array - divTensorR3Cell => scratch % divTensorR3Cell % array - outerProductEdge => scratch % outerProductEdge % array - normalVectorEdge => scratch % normalVectorEdge % array + if ( .not. config_use_mom_del2_tensor ) return + + call mpas_pool_get_config(ocnConfigs, 'config_mom_del2_tensor ', config_mom_del2_tensor ) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'edgeTangentVectors', edgeTangentVectors) + + call mpas_pool_get_field(scratchPool, 'strainRateR3Cell',strainRateR3CellField) + call mpas_pool_get_field(scratchPool, 'strainRateR3Edge',strainRateR3EdgeField) + call mpas_pool_get_field(scratchPool, 'divTensorR3Cell', divTensorR3CellField) + call mpas_pool_get_field(scratchPool, 'outerProductEdge',outerProductEdgeField) + call mpas_pool_get_field(scratchPool, 'normalVectorEdge',normalVectorEdgeField) + + call mpas_allocate_scratch_field(strainRateR3CellField, .true.) + call mpas_allocate_scratch_field(strainRateR3EdgeField, .true.) + call mpas_allocate_scratch_field(divTensorR3CellField, .true.) + call mpas_allocate_scratch_field(outerProductEdgeField, .true.) + call mpas_allocate_scratch_field(normalVectorEdgeField, .true.) + + strainRateR3Cell => strainRateR3CellField % array + strainRateR3Edge => strainRateR3EdgeField % array + divTensorR3Cell => divTensorR3CellField % array + outerProductEdge => outerProductEdgeField % array + normalVectorEdge => normalVectorEdgeField % array call mpas_strain_rate_R3Cell(normalVelocity, tangentialVelocity, & - mesh, edgeSignOnCell, edgeTangentVectors, .true., & + meshPool, edgeSignOnCell, edgeTangentVectors, .true., & outerProductEdge, strainRateR3Cell) - call mpas_matrix_cell_to_edge(strainRateR3Cell, mesh, .true., strainRateR3Edge) + call mpas_matrix_cell_to_edge(strainRateR3Cell, meshPool, .true., strainRateR3Edge) ! The following loop could possibly be reduced to nEdgesSolve - do iEdge=1,nEdges + do iEdge = 1, nEdges visc2 = config_mom_del2_tensor * meshScalingDel2(iEdge) - do k=1,maxLevelEdgeTop(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) strainRateR3Edge(:,k,iEdge) = visc2 * strainRateR3Edge(:,k,iEdge) viscosity(k,iEdge) = viscosity(k,iEdge) + visc2 end do ! Impose zero strain rate at land boundaries - do k=maxLevelEdgeTop(iEdge)+1,nVertLevels + do k = maxLevelEdgeTop(iEdge)+1, nVertLevels strainRateR3Edge(:,k,iEdge) = 0.0 end do end do ! may change boundaries to false later - call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, mesh, edgeSignOnCell, .true., divTensorR3Cell) + call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, meshPool, edgeSignOnCell, .true., divTensorR3Cell) - call mpas_vector_R3Cell_to_normalVectorEdge(divTensorR3Cell, mesh, .true., normalVectorEdge) + call mpas_vector_R3Cell_to_normalVectorEdge(divTensorR3Cell, meshPool, .true., normalVectorEdge) ! The following loop could possibly be reduced to nEdgesSolve - do iEdge=1,nEdges - do k=1,maxLevelEdgeTop(iEdge) + do iEdge = 1, nEdges + do k = 1, maxLevelEdgeTop(iEdge) tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * normalVectorEdge(k,iEdge) end do end do - call mpas_deallocate_scratch_field(scratch % strainRateR3Cell, .true.) - call mpas_deallocate_scratch_field(scratch % strainRateR3Edge, .true.) - call mpas_deallocate_scratch_field(scratch % divTensorR3Cell, .true.) - call mpas_deallocate_scratch_field(scratch % outerProductEdge, .true.) - call mpas_deallocate_scratch_field(scratch % normalVectorEdge, .true.) + call mpas_deallocate_scratch_field(strainRateR3CellField, .true.) + call mpas_deallocate_scratch_field(strainRateR3EdgeField, .true.) + call mpas_deallocate_scratch_field(divTensorR3CellField, .true.) + call mpas_deallocate_scratch_field(outerProductEdgeField, .true.) + call mpas_deallocate_scratch_field(normalVectorEdgeField, .true.) !-------------------------------------------------------------------- @@ -337,6 +360,9 @@ subroutine ocn_vel_hmix_del2_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + real (kind=RKIND), pointer :: config_mom_del2 + logical, pointer :: config_use_mom_del2 + !-------------------------------------------------------------------- ! ! set some local module variables based on input config choices @@ -345,13 +371,16 @@ subroutine ocn_vel_hmix_del2_init(err)!{{{ err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_mom_del2', config_mom_del2) + call mpas_pool_get_config(ocnConfigs, 'config_use_mom_del2', config_use_mom_del2) + hmixDel2On = .false. if ( config_mom_del2 > 0.0 ) then hmixDel2On = .true. endif - if(.not.config_use_mom_del2) hmixDel2On = .false. + if ( .not. config_use_mom_del2 ) hmixDel2On = .false. !-------------------------------------------------------------------- diff --git a/src/core_ocean/mpas_ocn_vel_hmix_del4.F b/src/core_ocean/shared/mpas_ocn_vel_hmix_del4.F similarity index 67% rename from src/core_ocean/mpas_ocn_vel_hmix_del4.F rename to src/core_ocean/shared/mpas_ocn_vel_hmix_del4.F index fb6bf8d843..a8428ffdee 100644 --- a/src/core_ocean/mpas_ocn_vel_hmix_del4.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix_del4.F @@ -21,10 +21,10 @@ module ocn_vel_hmix_del4 use mpas_grid_types - use mpas_configure use mpas_vector_operations use mpas_matrix_operations use mpas_tensor_operations + use ocn_constants implicit none private @@ -76,7 +76,7 @@ module ocn_vel_hmix_del4 ! !----------------------------------------------------------------------- - subroutine ocn_vel_hmix_del4_tend(mesh, divergence, relativeVorticity, tend, err)!{{{ + subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -90,8 +90,8 @@ subroutine ocn_vel_hmix_del4_tend(mesh, divergence, relativeVorticity, tend, err real (kind=RKIND), dimension(:,:), intent(in) :: & relativeVorticity !< Input: relative vorticity - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -118,7 +118,7 @@ subroutine ocn_vel_hmix_del4_tend(mesh, divergence, relativeVorticity, tend, err integer :: iEdge, cell1, cell2, vertex1, vertex2, k, i integer :: iCell, iVertex - integer :: nVertices, nVertLevels, nCells, nEdges, nEdgesSolve, vertexDegree + integer, pointer :: nVertices, nVertLevels, nCells, nEdges, nEdgesSolve, vertexDegree integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelVertexTop, & maxLevelCell, nEdgesOnCell @@ -133,33 +133,37 @@ subroutine ocn_vel_hmix_del4_tend(mesh, divergence, relativeVorticity, tend, err real (kind=RKIND), dimension(:,:), allocatable :: delsq_divergence, & delsq_circulation, delsq_relativeVorticity, delsq_u + real (kind=RKIND), pointer :: config_mom_del4 + err = 0 if(.not.hmixDel4On) return - nCells = mesh % nCells - nEdges = mesh % nEdges - nEdgesSolve = mesh % nEdgessolve - nVertices = mesh % nVertices - nVertLevels = mesh % nVertLevels - vertexDegree = mesh % vertexDegree - - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - maxLevelVertexTop => mesh % maxLevelVertexTop % array - maxLevelCell => mesh % maxLevelCell % array - cellsOnEdge => mesh % cellsOnEdge % array - verticesOnEdge => mesh % verticesOnEdge % array - dcEdge => mesh % dcEdge % array - dvEdge => mesh % dvEdge % array - areaTriangle => mesh % areaTriangle % array - areaCell => mesh % areaCell % array - meshScalingDel4 => mesh % meshScalingDel4 % array - edgeMask => mesh % edgeMask % array - nEdgesOnCell => mesh % nEdgesOnCell % array - edgesOnVertex => mesh % edgesOnVertex % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnVertex => mesh % edgeSignOnVertex % array - edgeSignOnCell => mesh % edgeSignOnCell % array + call mpas_pool_get_config(ocnConfigs, 'config_mom_del4', config_mom_del4) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelVertexTop', maxLevelVertexTop) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnVertex', edgeSignOnVertex) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) allocate(delsq_u(nVertLEvels, nEdges+1)) allocate(delsq_divergence(nVertLevels, nCells+1)) @@ -253,7 +257,7 @@ end subroutine ocn_vel_hmix_del4_tend!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vel_hmix_del4_tensor_tend(mesh, normalVelocity, tangentialVelocity, viscosity, scratch, tend, err)!{{{ + subroutine ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVelocity, viscosity, scratchPool, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -267,8 +271,8 @@ subroutine ocn_vel_hmix_del4_tensor_tend(mesh, normalVelocity, tangentialVelocit real (kind=RKIND), dimension(:,:), intent(in) :: & tangentialVelocity !< Input: velocity, tangent to an edge - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -279,8 +283,8 @@ subroutine ocn_vel_hmix_del4_tensor_tend(mesh, normalVelocity, tangentialVelocit real (kind=RKIND), dimension(:,:), intent(inout) :: & viscosity !< Input/Output: viscosity - type (scratch_type), intent(inout) :: & - scratch !< Input/Output: Scratch structure + type (mpas_pool_type), intent(inout) :: & + scratchPool !< Input/Output: Scratch structure real (kind=RKIND), dimension(:,:), intent(inout) :: & tend !< Input/Output: velocity tendency @@ -299,7 +303,8 @@ subroutine ocn_vel_hmix_del4_tensor_tend(mesh, normalVelocity, tangentialVelocit ! !----------------------------------------------------------------- - integer :: iEdge, nEdgesSolve, nEdges, k, nVertLevels + integer :: iEdge, k + integer, pointer :: nEdgesSolve, nEdges, nVertLevels integer, dimension(:), pointer :: maxLevelEdgeTop integer, dimension(:,:), pointer :: edgeMask, edgeSignOnCell @@ -309,6 +314,13 @@ subroutine ocn_vel_hmix_del4_tensor_tend(mesh, normalVelocity, tangentialVelocit real (kind=RKIND), dimension(:,:,:), pointer :: & strainRateR3Cell, strainRateR3Edge, divTensorR3Cell, outerProductEdge + type (field2DReal), pointer :: normalVectorEdgeField, tangentialVectorEdgeField + type (field3DReal), pointer :: strainRateR3CellField, strainRateR3EdgeField, divTensorR3CellField, outerProductEdgeField + + logical, pointer :: config_use_mom_del4_tensor + real (kind=RKIND), pointer :: config_mom_del4_tensor + + !----------------------------------------------------------------- ! ! exit if this mixing is not selected @@ -317,95 +329,106 @@ subroutine ocn_vel_hmix_del4_tensor_tend(mesh, normalVelocity, tangentialVelocit err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_use_mom_del4_tensor', config_use_mom_del4_tensor) + if(.not.config_use_mom_del4_tensor) return - nEdges = mesh % nEdges - nVertLevels = mesh % nVertLevels - nEdgesSolve = mesh % nEdgesSolve - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - meshScalingDel4 => mesh % meshScalingDel4 % array - edgeMask => mesh % edgeMask % array - edgeSignOnCell => mesh % edgeSignOnCell % array - edgeTangentVectors => mesh % edgeTangentVectors % array - - call mpas_allocate_scratch_field(scratch % strainRateR3Cell, .true.) - call mpas_allocate_scratch_field(scratch % strainRateR3Edge, .true.) - call mpas_allocate_scratch_field(scratch % divTensorR3Cell, .true.) - call mpas_allocate_scratch_field(scratch % outerProductEdge, .true.) - call mpas_allocate_scratch_field(scratch % normalVectorEdge, .true.) - call mpas_allocate_scratch_field(scratch % tangentialVectorEdge, .true.) - - strainRateR3Cell => scratch % strainRateR3Cell % array - strainRateR3Edge => scratch % strainRateR3Edge % array - divTensorR3Cell => scratch % divTensorR3Cell % array - outerProductEdge => scratch % outerProductEdge % array - normalVectorEdge => scratch % normalVectorEdge % array - tangentialVectorEdge => scratch % tangentialVectorEdge % array + call mpas_pool_get_config(ocnConfigs, 'config_mom_del4_tensor', config_mom_del4_tensor) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'edgeTangentVectors', edgeTangentVectors) + + call mpas_pool_get_field(scratchPool, 'strainRateR3Cell', strainRateR3CellField) + call mpas_pool_get_field(scratchPool, 'strainRateR3Edge', strainRateR3EdgeField) + call mpas_pool_get_field(scratchPool, 'divTensorR3Cell', divTensorR3CellField) + call mpas_pool_get_field(scratchPool, 'outerProductEdge', outerProductEdgeField) + call mpas_pool_get_field(scratchPool, 'normalVectorEdge', normalVectorEdgeField) + call mpas_pool_get_field(scratchPool, 'tangentialVectorEdge', tangentialVectorEdgeField) + + call mpas_allocate_scratch_field(strainRateR3CellField, .true.) + call mpas_allocate_scratch_field(strainRateR3EdgeField, .true.) + call mpas_allocate_scratch_field(divTensorR3CellField, .true.) + call mpas_allocate_scratch_field(outerProductEdgeField, .true.) + call mpas_allocate_scratch_field(normalVectorEdgeField, .true.) + call mpas_allocate_scratch_field(tangentialVectorEdgeField, .true.) + + strainRateR3Cell => strainRateR3CellField % array + strainRateR3Edge => strainRateR3EdgeField % array + divTensorR3Cell => divTensorR3CellField % array + outerProductEdge => outerProductEdgeField % array + normalVectorEdge => normalVectorEdgeField % array + tangentialVectorEdge => tangentialVectorEdgeField % array !!!!!!! first div(grad()) call mpas_strain_rate_R3Cell(normalVelocity, tangentialVelocity, & - mesh, edgeSignOnCell, edgeTangentVectors, .true., & + meshPool, edgeSignOnCell, edgeTangentVectors, .true., & outerProductEdge, strainRateR3Cell) - call mpas_matrix_cell_to_edge(strainRateR3Cell, mesh, .true., strainRateR3Edge) + call mpas_matrix_cell_to_edge(strainRateR3Cell, meshPool, .true., strainRateR3Edge) ! The following loop could possibly be reduced to nEdgesSolve - do iEdge=1,nEdges + do iEdge = 1, nEdges visc4_sqrt = sqrt(config_mom_del4_tensor * meshScalingDel4(iEdge)) - do k=1,maxLevelEdgeTop(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) strainRateR3Edge(:,k,iEdge) = visc4_sqrt * strainRateR3Edge(:,k,iEdge) end do ! Impose zero strain rate at land boundaries - do k=maxLevelEdgeTop(iEdge)+1,nVertLevels + do k = maxLevelEdgeTop(iEdge)+1, nVertLevels strainRateR3Edge(:,k,iEdge) = 0.0 end do end do ! may change boundaries to false later - call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, mesh, edgeSignOnCell, .true., divTensorR3Cell) + call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, meshPool, edgeSignOnCell, .true., divTensorR3Cell) - call mpas_vector_R3Cell_to_2DEdge(divTensorR3Cell, mesh, edgeTangentVectors, .true., normalVectorEdge, tangentialVectorEdge) + call mpas_vector_R3Cell_to_2DEdge(divTensorR3Cell, meshPool, edgeTangentVectors, .true., normalVectorEdge, tangentialVectorEdge) !!!!!!! second div(grad()) call mpas_strain_rate_R3Cell(normalVectorEdge, tangentialVectorEdge, & - mesh, edgeSignOnCell, edgeTangentVectors, .true., & + meshPool, edgeSignOnCell, edgeTangentVectors, .true., & outerProductEdge, strainRateR3Cell) - call mpas_matrix_cell_to_edge(strainRateR3Cell, mesh, .true., strainRateR3Edge) + call mpas_matrix_cell_to_edge(strainRateR3Cell, meshPool, .true., strainRateR3Edge) ! The following loop could possibly be reduced to nEdgesSolve - do iEdge=1,nEdges + do iEdge = 1, nEdges visc4_sqrt = sqrt(config_mom_del4_tensor * meshScalingDel4(iEdge)) viscosity(:,iEdge) = viscosity(:,iEdge) + config_mom_del4_tensor * meshScalingDel4(iEdge) - do k=1,maxLevelEdgeTop(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) strainRateR3Edge(:,k,iEdge) = visc4_sqrt * strainRateR3Edge(:,k,iEdge) end do ! Impose zero strain rate at land boundaries - do k=maxLevelEdgeTop(iEdge)+1,nVertLevels + do k = maxLevelEdgeTop(iEdge)+1, nVertLevels strainRateR3Edge(:,k,iEdge) = 0.0 end do end do ! may change boundaries to false later - call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, mesh, edgeSignOnCell, .true., divTensorR3Cell) + call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, meshPool, edgeSignOnCell, .true., divTensorR3Cell) - call mpas_vector_R3Cell_to_normalVectorEdge(divTensorR3Cell, mesh, .true., normalVectorEdge) + call mpas_vector_R3Cell_to_normalVectorEdge(divTensorR3Cell, meshPool, .true., normalVectorEdge) ! The following loop could possibly be reduced to nEdgesSolve - do iEdge=1,nEdges - do k=1,maxLevelEdgeTop(iEdge) + do iEdge = 1,nEdges + do k = 1,maxLevelEdgeTop(iEdge) tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * normalVectorEdge(k,iEdge) end do end do - call mpas_deallocate_scratch_field(scratch % strainRateR3Cell, .true.) - call mpas_deallocate_scratch_field(scratch % strainRateR3Edge, .true.) - call mpas_deallocate_scratch_field(scratch % divTensorR3Cell, .true.) - call mpas_deallocate_scratch_field(scratch % outerProductEdge, .true.) - call mpas_deallocate_scratch_field(scratch % normalVectorEdge, .true.) - call mpas_deallocate_scratch_field(scratch % tangentialVectorEdge, .true.) + call mpas_deallocate_scratch_field(strainRateR3CellField, .true.) + call mpas_deallocate_scratch_field(strainRateR3EdgeField, .true.) + call mpas_deallocate_scratch_field(divTensorR3CellField, .true.) + call mpas_deallocate_scratch_field(outerProductEdgeField, .true.) + call mpas_deallocate_scratch_field(normalVectorEdgeField, .true.) + call mpas_deallocate_scratch_field(tangentialVectorEdgeField, .true.) !-------------------------------------------------------------------- @@ -434,8 +457,14 @@ subroutine ocn_vel_hmix_del4_init(err)!{{{ ! !-------------------------------------------------------------------- + real (kind=RKIND), pointer :: config_mom_del4 + logical, pointer :: config_use_mom_del4 + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_mom_del4', config_mom_del4) + call mpas_pool_get_config(ocnConfigs, 'config_use_mom_del4', config_use_mom_del4) + hmixDel4On = .false. if ( config_mom_del4 > 0.0 ) then diff --git a/src/core_ocean/mpas_ocn_vel_hmix_leith.F b/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F similarity index 83% rename from src/core_ocean/mpas_ocn_vel_hmix_leith.F rename to src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F index d6f4fdb6c1..46b270897c 100644 --- a/src/core_ocean/mpas_ocn_vel_hmix_leith.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F @@ -21,7 +21,7 @@ module ocn_vel_hmix_leith use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -78,7 +78,7 @@ module ocn_vel_hmix_leith ! !----------------------------------------------------------------------- - subroutine ocn_vel_hmix_leith_tend(mesh, divergence, relativeVorticity, viscosity, tend, err)!{{{ + subroutine ocn_vel_hmix_leith_tend(meshPool, divergence, relativeVorticity, viscosity, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -92,8 +92,8 @@ subroutine ocn_vel_hmix_leith_tend(mesh, divergence, relativeVorticity, viscosit real (kind=RKIND), dimension(:,:), intent(in) :: & relativeVorticity !< Input: relative vorticity - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -121,7 +121,8 @@ subroutine ocn_vel_hmix_leith_tend(mesh, divergence, relativeVorticity, viscosit ! !----------------------------------------------------------------- - integer :: iEdge, nEdgesSolve, cell1, cell2, vertex1, vertex2, k + integer :: iEdge, cell1, cell2, vertex1, vertex2, k + integer, pointer :: nEdgesSolve integer, dimension(:), pointer :: maxLevelEdgeTop integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask @@ -129,6 +130,8 @@ subroutine ocn_vel_hmix_leith_tend(mesh, divergence, relativeVorticity, viscosit real (kind=RKIND), dimension(:), pointer :: meshScaling, & dcEdge, dvEdge + real (kind=RKIND), pointer :: config_leith_parameter, config_leith_dx, config_leith_visc2_max + !----------------------------------------------------------------- ! ! exit if this mixing is not selected @@ -139,16 +142,21 @@ subroutine ocn_vel_hmix_leith_tend(mesh, divergence, relativeVorticity, viscosit if(.not.hmixLeithOn) return - nEdgesSolve = mesh % nEdgesSolve - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - cellsOnEdge => mesh % cellsOnEdge % array - verticesOnEdge => mesh % verticesOnEdge % array - meshScaling => mesh % meshScaling % array - edgeMask => mesh % edgeMask % array - dcEdge => mesh % dcEdge % array - dvEdge => mesh % dvEdge % array + call mpas_pool_get_config(ocnConfigs, 'config_Leith_parameter', config_leith_parameter) + call mpas_pool_get_config(ocnConfigs, 'config_Leith_dx', config_leith_dx) + call mpas_pool_get_config(ocnConfigs, 'config_Leith_visc2_max', config_leith_visc2_max) + + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - do iEdge=1,nEdgesSolve + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'meshScaling', meshScaling) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + + do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) vertex1 = verticesOnEdge(1,iEdge) @@ -157,7 +165,7 @@ subroutine ocn_vel_hmix_leith_tend(mesh, divergence, relativeVorticity, viscosit invLength1 = 1.0 / dcEdge(iEdge) invLength2 = 1.0 / dvEdge(iEdge) - do k=1,maxLevelEdgeTop(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) ! Here -( relativeVorticity(k,vertex2) - relativeVorticity(k,vertex1) ) / dvEdge(iEdge) ! is - \nabla relativeVorticity pointing from vertex 2 to vertex 1, or equivalently @@ -207,9 +215,12 @@ subroutine ocn_vel_hmix_leith_init(err)!{{{ ! set some local module variables based on input config choices ! !-------------------------------------------------------------------- + logical, pointer :: config_use_Leith_del2 err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_use_Leith_del2', config_use_Leith_del2) + hmixLeithOn = .false. if (config_use_leith_del2) then diff --git a/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F b/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F new file mode 100644 index 0000000000..360bab0caa --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F @@ -0,0 +1,648 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_vel_pressure_grad +! +!> \brief MPAS ocean pressure gradient module +!> \author Mark Petersen +!> \date September 2011 +!> \details +!> This module contains the routine for computing +!> tendencie from the horizontal pressure gradient. +!> +! +!----------------------------------------------------------------------- + +module ocn_vel_pressure_grad + + use mpas_grid_types + use mpas_constants + use mpas_io_units + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_vel_pressure_grad_tend, & + ocn_vel_pressure_grad_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + character (len=StrKIND), pointer :: config_pressure_gradient_type + real (kind=RKIND), pointer :: config_common_level_weight + logical :: pgradOn + real (kind=RKIND) :: density0Inv, gdensity0Inv, inv12 + + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_vel_pressure_grad_tend +! +!> \brief Computes tendency term for horizontal pressure gradient +!> \author Mark Petersen +!> \date February 2014 +!> \details +!> This routine computes the pressure gradient tendency for momentum +!> based on current state. +! +!----------------------------------------------------------------------- + + subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, zMid, density, potentialDensity, & + indexT, indexS, tracers, tend, err, inSituThermalExpansionCoeff,inSituSalineContractionCoeff)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: indexT, indexS + + real (kind=RKIND), dimension(:,:), intent(in) :: & + pressure, & !< Input: Pressure field + montgomeryPotential, & !< Input: Mongomery potential + zMid, & !< Input: z-coordinate at mid-depth of layer + density, & !< Input: density + potentialDensity !< Input: potentialDensity + + real (kind=RKIND), dimension(:,:), intent(in), optional :: & + inSituThermalExpansionCoeff, & + inSituSalineContractionCoeff + + real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh 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, k, cell1, cell2, iCell, kMax + integer, pointer :: nVertLevels, nCells, nEdgesSolve + integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask + + real (kind=RKIND), dimension(:), pointer :: dcEdge + real (kind=RKIND), dimension(:), allocatable :: JacobianDxDs,JacobianTz,JacobianSz,T1,T2,S1,S2 + real (kind=RKIND), dimension(:,:), allocatable :: FXTop, work1, work2 + real (kind=RKIND) :: invdcEdge, pGrad, sumAJTop, AJTop, FC, FCPrev, alpha, beta + + err = 0 + + if (.not. pgradOn) return + + call mpas_pool_get_dimension(meshPool, 'nVertLevels',nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCells',nCells) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + + if (config_pressure_gradient_type.eq.'pressure_and_zmid') then + + ! pressure for generalized coordinates + ! -1/density_0 (grad p_k + density g grad z_k^{mid}) + + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + invdcEdge = 1.0 / dcEdge(iEdge) + + do k=1,maxLevelEdgeTop(iEdge) + tend(k,iEdge) = tend(k,iEdge) + edgeMask(k,iEdge) * invdcEdge * ( & + - density0Inv * ( pressure(k,cell2) - pressure(k,cell1) ) & + - gdensity0Inv * 0.5*(density(k,cell1)+density(k,cell2)) * ( zMid(k,cell2) - zMid(k,cell1) ) ) + end do + end do + + elseif (config_pressure_gradient_type.eq.'MontgomeryPotential') then + + ! For pure isopycnal coordinates, this is just grad(M), + ! the gradient of Montgomery Potential + + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + invdcEdge = 1.0 / dcEdge(iEdge) + + do k=1,maxLevelEdgeTop(iEdge) + tend(k,iEdge) = tend(k,iEdge) + edgeMask(k,iEdge) * invdcEdge * ( & + - ( montgomeryPotential(k,cell2) - montgomeryPotential(k,cell1) ) ) + end do + end do + + elseif (config_pressure_gradient_type.eq.'MontgomeryPotential_and_density') then + + ! This formulation has not been extensively tested and is not supported at this time. + + ! This is -grad(M)+p grad(1/rho) + ! Where rho is the potential density. + ! See Bleck (2002) equation 1, and last equation in Appendix A. + + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + invdcEdge = 1.0 / dcEdge(iEdge) + + do k=1,maxLevelEdgeTop(iEdge) + tend(k,iEdge) = tend(k,iEdge) + edgeMask(k,iEdge) * invdcEdge * ( & + - ( montgomeryPotential(k,cell2) - montgomeryPotential(k,cell1) ) & + + 0.5*(pressure(k,cell1)+pressure(k,cell2)) * ( 1.0/potentialDensity(k,cell2) - 1.0/potentialDensity(k,cell1) ) ) + end do + end do + + elseif (config_pressure_gradient_type.eq.'Jacobian_from_density') then + + allocate(JacobianDxDs(nVertLevels)) + + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + invdcEdge = 1.0 / dcEdge(iEdge) + + call pGrad_Jacobian_common_level(density(:,cell1),density(:,cell2),zMid(:,cell1),zMid(:,cell2), & + maxLevelEdgeTop(iEdge), config_common_level_weight, JacobianDxDs) + + ! In layer 1, use pressure for generalized coordinates + ! pGrad = -1/density_0 (grad p_k + density g grad z_k^{mid}) + k = 1 + pGrad = edgeMask(k,iEdge) * invdcEdge * ( & + - density0Inv * ( pressure(k,cell2) - pressure(k,cell1) ) & + - gdensity0Inv * 0.5*(density(k,cell1)+density(k,cell2)) * ( zMid(k,cell2) - zMid(k,cell1) ) ) + + tend(k,iEdge) = tend(k,iEdge) + pGrad + + do k=2,maxLevelEdgeTop(iEdge) + + ! note JacobianDxDs includes negative sign, so + ! pGrad is - g/rho_0 dP/dx + + pGrad = pGrad + gdensity0Inv * JacobianDxDs(k) * invdcEdge + + tend(k,iEdge) = tend(k,iEdge) + pGrad + + end do + end do + + deallocate(JacobianDxDs) + + elseif (config_pressure_gradient_type.eq.'Jacobian_from_TS') then + + allocate(JacobianDxDs(nVertLevels),JacobianTz(nVertLevels),JacobianSz(nVertLevels), T1(nVertLevels), T2(nVertLevels), S1(nVertLevels), S2(nVertLevels)) + + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + invdcEdge = 1.0 / dcEdge(iEdge) + kMax = maxLevelEdgeTop(iEdge) + + ! copy T and S to local column arrays + T1(1:kMax) = tracers(indexT,1:kMax,cell1) + T2(1:kMax) = tracers(indexT,1:kMax,cell2) + S1(1:kMax) = tracers(indexS,1:kMax,cell1) + S2(1:kMax) = tracers(indexS,1:kMax,cell2) + + ! compute J(T,z) and J(S,z) in Shchepetkin and McWilliams (2003) (7.16) + call pGrad_Jacobian_common_level(T1, T2 ,zMid(:,cell1),zMid(:,cell2),kMax,config_common_level_weight, JacobianTz) + call pGrad_Jacobian_common_level(S1, S2 ,zMid(:,cell1),zMid(:,cell2),kMax,config_common_level_weight, JacobianSz) + + ! In layer 1, use pressure for generalized coordinates + ! pGrad = -1/density_0 (grad p_k + density g grad z_k^{mid}) + k = 1 + pGrad = edgeMask(k,iEdge) * invdcEdge * ( & + - density0Inv * ( pressure(k,cell2) - pressure(k,cell1) ) & + - gdensity0Inv * 0.5*(density(k,cell1)+density(k,cell2)) * ( zMid(k,cell2) - zMid(k,cell1) ) ) + + tend(k,iEdge) = tend(k,iEdge) + pGrad + + do k=2,kMax + + ! Average alpha and beta over four data points of the Jacobian cell. + ! Note that inSituThermalExpansionCoeff and inSituSalineContractionCoeff include a 1/density factor, + ! so must multiply by density here. + alpha = 0.25*( density(k,cell1)*inSituThermalExpansionCoeff (k,cell1) + density(k-1,cell1)*inSituThermalExpansionCoeff (k-1,cell1) & + + density(k,cell2)*inSituThermalExpansionCoeff (k,cell2) + density(k-1,cell2)*inSituThermalExpansionCoeff (k-1,cell2) ) + beta = 0.25*( density(k,cell1)*inSituSalineContractionCoeff(k,cell1) + density(k-1,cell1)*inSituSalineContractionCoeff(k-1,cell1) & + + density(k,cell2)*inSituSalineContractionCoeff(k,cell2) + density(k-1,cell2)*inSituSalineContractionCoeff(k-1,cell2) ) + + ! Shchepetkin and McWilliams (2003) (7.16) + JacobianDxDs(k) = -alpha*JacobianTz(k) + beta*JacobianSz(k) + + ! note JacobianDxDs includes negative sign, so + ! pGrad is - g/rho_0 dP/dx + + pGrad = pGrad + gdensity0Inv * JacobianDxDs(k) * invdcEdge + + tend(k,iEdge) = tend(k,iEdge) + pGrad + + end do + end do + + deallocate(JacobianDxDs,JacobianTz,JacobianSz, T1, T2, S1, S2) + + else + + write (stderrUnit,'(a,a)') ' Pressure type is: ',trim(config_pressure_gradient_type) + write (stderrUnit,*) ' Incorrect choice of config_pressure_gradient_type.' + err = 1 + + endif + + !-------------------------------------------------------------------- + + end subroutine ocn_vel_pressure_grad_tend!}}} + +!*********************************************************************** +! +! routine pGrad_Jacobian_common_level +! +!> \brief Computes density-Jacobian +!> \author Mark Petersen +!> \date February 2014 +!> \details +!> This routine computes the density-Jacobian in common_level form. +!> See Shchepetkin and McWilliams (2003) Ocean Modeling, sections 2-4 +! +!----------------------------------------------------------------------- + + subroutine pGrad_Jacobian_common_level(rho1,rho2,z1,z2,kMax,gamma,JacobianDxDs) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + rho1, & ! density of column 1 + rho2, & ! density of column 2 + z1, & ! z-coordinate at middle of cell, column 1 + z2 ! z-coordinate at middle of cell, column 2 + + real (kind=RKIND), intent(in) :: & + gamma ! weight between zStar (original Jacobian) and z_C (weighted Jacobian) + + integer, intent(in) :: & + kMax + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + JacobianDxDs ! - Delta x Delta s J(rho,z) + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: k + real (kind=RKIND) :: Area, zStar, rhoL, rhoR, zC, zGamma + + JacobianDxDs = 0.0 + + do k=2,kMax + + ! eqn 2.7 in Shchepetkin and McWilliams (2003) + ! Note delta x was removed. It must be an error in the paper, + ! as it makes the units incorrect. + Area = 0.5*(z1(k-1) - z1(k) + z2(k-1) - z2(k) ) + + ! eqn 2.8 + zStar = ( z2(k-1)*z1(k-1) - z2(k)*z1(k) )/(z2(k-1)-z2(k) + z1(k-1)-z1(k)) + + ! eqn 3.2 + zC = 0.25*( z1(k) + z1(k-1) + z2(k) + z2(k-1) ) + + ! eqn 4.1 + zGamma = (1.0 - gamma)*zStar + gamma*zC + + rhoL = (rho1(k)*(z1(k-1)-zGamma) + rho1(k-1)*(zGamma-z1(k)))/(z1(k-1) - z1(k)) + rhoR = (rho2(k)*(z2(k-1)-zGamma) + rho2(k-1)*(zGamma-z2(k)))/(z2(k-1) - z2(k)) + + ! eqn 2.6 in Shchepetkin and McWilliams (2003) + JacobianDxDs(k) = Area * (rhoL - rhoR) + end do + + end subroutine pGrad_Jacobian_common_level + +!*********************************************************************** +! +! routine pGrad_Jacobian_POM_SCRUM +! +!> \brief Computes density-Jacobian +!> \author Mark Petersen +!> \date February 2014 +!> \details +!> This routine computes the density-Jacobian in POM/SCRUM form. +!> See Shchepetkin and McWilliams (2003) Ocean Modeling, section 2. +! +!----------------------------------------------------------------------- + + subroutine pGrad_Jacobian_POM_SCRUM(rho1,rho2,z1,z2,kMax,JacobianDxDs) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + rho1, & ! density of column 1 + rho2, & ! density of column 2 + z1, & ! z-coordinate at middle of cell, column 1 + z2 ! z-coordinate at middle of cell, column 2 + + integer, intent(in) :: & + kMax ! maximum level + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + JacobianDxDs ! - Delta x Delta s J(rho,z) + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: k + + JacobianDxDs = 0.0 + + do k=2,kMax + + ! eqn 2.3 in Shchepetkin and McWilliams (2003) + JacobianDxDs(k) = 0.25*(& + (rho1(k) + rho1(k-1) - rho2(k) - rho2(k-1) )*(z1(k-1) - z1(k) + z2(k-1) - z2(k) ) & + - (rho1(k-1) - rho1(k) + rho2(k-1) - rho2(k) )*(z1(k) + z1(k-1) - z2(k) - z2(k-1) ) ) + end do + + end subroutine pGrad_Jacobian_POM_SCRUM + +!*********************************************************************** +! +! routine pGrad_Jacobian_diagonal +! +!> \brief Computes density-Jacobian +!> \author Mark Petersen +!> \date February 2014 +!> \details +!> This routine computes the density-Jacobian in diagonal form. +!> See Shchepetkin and McWilliams (2003) Ocean Modeling, section 2. +! +!----------------------------------------------------------------------- + + subroutine pGrad_Jacobian_diagonal(rho1,rho2,z1,z2,kMax,JacobianDxDs) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + rho1, & ! density of column 1 + rho2, & ! density of column 2 + z1, & ! z-coordinate at middle of cell, column 1 + z2 ! z-coordinate at middle of cell, column 2 + + integer, intent(in) :: & + kMax + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + JacobianDxDs ! - Delta x Delta s J(rho,z) + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: k + + JacobianDxDs = 0.0 + + do k=2,kMax + + ! eqn 2.5 in Shchepetkin and McWilliams (2003) + JacobianDxDs(k) = 0.5*( & + (rho1(k-1) - rho2(k))*(z2(k-1) - z1(k) ) & + + (rho1(k) - rho2(k-1))*(z1(k-1) - z2(k)) ) + end do + + end subroutine pGrad_Jacobian_diagonal + +!*********************************************************************** +! +! routine pGrad_Jacobian_pseudo_flux +! +!> \brief Computes density-Jacobian +!> \author Mark Petersen +!> \date February 2014 +!> \details +!> This routine computes the density-Jacobian in pseudo_flux form. +!> See Shchepetkin and McWilliams (2003) Ocean Modeling, section 2. +! +!----------------------------------------------------------------------- + + subroutine pGrad_Jacobian_pseudo_flux(rho1,rho2,z1,z2,kMax,JacobianDxDs) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + rho1, & ! density of column 1 + rho2, & ! density of column 2 + z1, & ! z-coordinate at middle of cell, column 1 + z2 ! z-coordinate at middle of cell, column 2 + + integer, intent(in) :: & + kMax + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + JacobianDxDs ! - Delta x Delta s J(rho,z) + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: k + real (kind=RKIND) :: FLeft, FTop, FRight, FBottom + + JacobianDxDs = 0.0 + + do k=2,kMax + + FLeft = 0.5*( rho1(k) + rho1(k-1) ) * (z1(k-1) - z1(k)) + FTop = 0.5*( rho1(k-1) + rho2(k-1) ) * (z2(k-1) - z1(k-1)) + FRight = 0.5*( rho2(k) + rho2(k-1) ) * (z2(k-1) - z2(k)) + FBottom = 0.5*( rho1(k) + rho2(k) ) * (z2(k) - z1(k)) + + ! eqn 2.11 in Shchepetkin and McWilliams (2003) + JacobianDxDs(k) = FLeft + FTop - FRight - FBottom + end do + + end subroutine pGrad_Jacobian_pseudo_flux + +!*********************************************************************** +! +! routine ocn_vel_pressure_grad_init +! +!> \brief Initializes ocean momentum horizontal pressure gradient +!> \author Mark Petersen +!> \date September 2011 +!> \details +!> This routine initializes parameters required for the computation of the +!> horizontal pressure gradient. +! +!----------------------------------------------------------------------- + + subroutine ocn_vel_pressure_grad_init(err)!{{{ + + !-------------------------------------------------------------------- + + + !----------------------------------------------------------------- + ! + ! Output Variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + + !----------------------------------------------------------------- + ! + ! call individual init routines for each parameterization + ! + !----------------------------------------------------------------- + real (kind=RKIND), pointer :: config_density0 + logical, pointer :: config_disable_vel_pgrad + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_pressure_gradient_type', config_pressure_gradient_type) + call mpas_pool_get_config(ocnConfigs, 'config_common_level_weight', config_common_level_weight) + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_pgrad', config_disable_vel_pgrad) + + pgradOn = .true. + + density0Inv = 1.0/config_density0 + gdensity0Inv = gravity/config_density0 + inv12 = 1.0/12.0 + + if (config_disable_vel_pgrad) pgradOn = .false. + + write (stdoutUnit,'(a,a)') ' Pressure type is: ',trim(config_pressure_gradient_type) + + !-------------------------------------------------------------------- + + end subroutine ocn_vel_pressure_grad_init!}}} + +!*********************************************************************** + +end module ocn_vel_pressure_grad + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/src/core_ocean/mpas_ocn_vel_vadv.F b/src/core_ocean/shared/mpas_ocn_vel_vadv.F similarity index 75% rename from src/core_ocean/mpas_ocn_vel_vadv.F rename to src/core_ocean/shared/mpas_ocn_vel_vadv.F index 85332ac9d9..eb9577bc8c 100644 --- a/src/core_ocean/mpas_ocn_vel_vadv.F +++ b/src/core_ocean/shared/mpas_ocn_vel_vadv.F @@ -22,7 +22,7 @@ module ocn_vel_vadv use mpas_grid_types - use mpas_configure + use ocn_constants implicit none private @@ -69,7 +69,7 @@ module ocn_vel_vadv ! !----------------------------------------------------------------------- - subroutine ocn_vel_vadv_tend(mesh, u, layerThicknessEdge, vertTransportVelocityTop, tend, err)!{{{ + subroutine ocn_vel_vadv_tend(meshPool, normalVelocity, layerThicknessEdge, vertAleTransportTop, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -78,13 +78,13 @@ subroutine ocn_vel_vadv_tend(mesh, u, layerThicknessEdge, vertTransportVelocityT !----------------------------------------------------------------- real (kind=RKIND), dimension(:,:), intent(in) :: & - u !< Input: Horizontal velocity + normalVelocity !< Input: Horizontal velocity real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge,&!< Input: thickness at edge - vertTransportVelocityTop !< Input: Vertical velocity on top layer + vertAleTransportTop !< Input: Vertical velocity on top layer - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -109,41 +109,41 @@ subroutine ocn_vel_vadv_tend(mesh, u, layerThicknessEdge, vertTransportVelocityT ! !----------------------------------------------------------------- - integer :: iEdge, nEdgesSolve, cell1, cell2, k - integer :: nVertLevels + integer :: iEdge, cell1, cell2, k + integer, pointer :: nEdgesSolve, nVertLevels integer, dimension(:), pointer :: maxLevelEdgeTop integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask - real (kind=RKIND) :: vertTransportVelocityTopEdge + real (kind=RKIND) :: vertAleTransportTopEdge real (kind=RKIND), dimension(:), allocatable :: w_dudzTopEdge - if(.not.velVadvOn) return + if (.not. velVadvOn) return err = 0 - nVertLevels = mesh % nVertLevels - nEdgesSolve = mesh % nEdgesSolve - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - cellsOnEdge => mesh % cellsOnEdge % array - edgeMask => mesh % edgeMask % array + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) allocate(w_dudzTopEdge(nVertLevels+1)) w_dudzTopEdge = 0.0 - do iEdge=1,nEdgesSolve + do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - do k=2,maxLevelEdgeTop(iEdge) + do k = 2, maxLevelEdgeTop(iEdge) ! Average w from cell center to edge - vertTransportVelocityTopEdge = 0.5*(vertTransportVelocityTop(k,cell1)+vertTransportVelocityTop(k,cell2)) + vertAleTransportTopEdge = 0.5*(vertAleTransportTop(k,cell1) + vertAleTransportTop(k,cell2)) ! compute dudz at vertical interface with first order derivative. - w_dudzTopEdge(k) = vertTransportVelocityTopEdge * (u(k-1,iEdge)-u(k,iEdge)) & + w_dudzTopEdge(k) = vertAleTransportTopEdge * (normalVelocity(k-1,iEdge)-normalVelocity(k,iEdge)) & / (0.5*(layerThicknessEdge(k-1,iEdge) + layerThicknessEdge(k,iEdge))) end do w_dudzTopEdge(maxLevelEdgeTop(iEdge)+1) = 0.0 ! Average w*du/dz from vertical interface to vertical middle of cell - do k=1,maxLevelEdgeTop(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * 0.5 * (w_dudzTopEdge(k) + w_dudzTopEdge(k+1)) enddo @@ -179,14 +179,21 @@ subroutine ocn_vel_vadv_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + character (len=StrKIND), pointer :: config_vert_coord_movement + logical, pointer :: config_disable_vel_vadv + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_vert_coord_movement', config_vert_coord_movement) + call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_vadv', config_disable_vel_vadv) + velVadvOn = .false. - if (config_vert_coord_movement.ne.'impermeable_interfaces') then + if (config_vert_coord_movement .ne.'impermeable_interfaces') then velVadvOn = .true. end if - if(config_disable_vel_vadv) velVadvOn = .false. + if ( config_disable_vel_vadv ) velVadvOn = .false. !-------------------------------------------------------------------- diff --git a/src/core_ocean/mpas_ocn_vmix.F b/src/core_ocean/shared/mpas_ocn_vmix.F similarity index 60% rename from src/core_ocean/mpas_ocn_vmix.F rename to src/core_ocean/shared/mpas_ocn_vmix.F index 8b1cee1dc0..502e8c47c5 100644 --- a/src/core_ocean/mpas_ocn_vmix.F +++ b/src/core_ocean/shared/mpas_ocn_vmix.F @@ -23,13 +23,14 @@ module ocn_vmix use mpas_kind_types use mpas_grid_types - use mpas_configure use mpas_timer + use ocn_constants use ocn_vmix_coefs_const use ocn_vmix_coefs_tanh use ocn_vmix_coefs_rich use ocn_vmix_cvmix + use ocn_vmix_coefs_redi implicit none private @@ -81,7 +82,7 @@ module ocn_vmix ! !----------------------------------------------------------------------- - subroutine ocn_vmix_coefs(mesh, s, d, err)!{{{ + subroutine ocn_vmix_coefs(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ !----------------------------------------------------------------- ! @@ -89,8 +90,10 @@ subroutine ocn_vmix_coefs(mesh, s, d, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state pool !----------------------------------------------------------------- ! @@ -98,11 +101,11 @@ subroutine ocn_vmix_coefs(mesh, s, d, err)!{{{ ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - s !< Input/Output: state information + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state information - type (diagnostics_type), intent(inout) :: & - d !< Input/Output: diagnostic information + type (mpas_pool_type), intent(inout) :: & + diagnosticsPool !< Input/Output: diagnostic information !----------------------------------------------------------------- ! @@ -118,7 +121,10 @@ subroutine ocn_vmix_coefs(mesh, s, d, err)!{{{ ! !----------------------------------------------------------------- - integer :: err1, err2, err3, err4 + integer :: err1, err2, err3, err4, err5 + integer :: timeLevel + + real (kind=RKIND), dimension(:,:), pointer :: vertViscTopOfEdge, vertDiffTopOfCell !----------------------------------------------------------------- ! @@ -128,17 +134,24 @@ subroutine ocn_vmix_coefs(mesh, s, d, err)!{{{ err = 0 - d % vertViscTopOfEdge % array = 0.0_RKIND - d % vertDiffTopOfCell % array = 0.0_RKIND + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfEdge', vertViscTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + vertViscTopOfEdge = 0.0_RKIND + vertDiffTopOfCell = 0.0_RKIND - call ocn_vmix_coefs_const_build(mesh, s, d, err1) - call ocn_vmix_coefs_tanh_build(mesh, s, d, err2) - call ocn_vmix_coefs_rich_build(mesh, s, d, err3) - call ocn_vmix_coefs_cvmix_build(mesh, s, d, err4) + call ocn_vmix_coefs_const_build(meshPool, statePool, diagnosticsPool, err1, timeLevel) + call ocn_vmix_coefs_tanh_build(meshPool, statePool, diagnosticsPool, err2, timeLevel) + call ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err3, timeLevel) + call ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err4, timeLevel) + call ocn_vmix_coefs_redi_build(meshPool, statePool, diagnosticsPool, err5, timeLevel) - err = ior(err1, err2) - err = ior(err, err3) - err = ior(err, err4) + err = ior(ior(ior(err1, ior(err2, err3)), err4), err5) !-------------------------------------------------------------------- @@ -157,7 +170,7 @@ end subroutine ocn_vmix_coefs!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vel_vmix_tend_implicit(mesh, dt, kineticEnergyCell, vertViscTopOfEdge, layerThickness, layerThicknessEdge, normalVelocity, err)!{{{ + subroutine ocn_vel_vmix_tend_implicit(meshPool, dt, kineticEnergyCell, vertViscTopOfEdge, layerThickness, layerThicknessEdge, normalVelocity, err)!{{{ !----------------------------------------------------------------- ! @@ -165,8 +178,8 @@ subroutine ocn_vel_vmix_tend_implicit(mesh, dt, kineticEnergyCell, vertViscTopOf ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & kineticEnergyCell !< Input: kinetic energy at cell @@ -206,7 +219,8 @@ subroutine ocn_vel_vmix_tend_implicit(mesh, dt, kineticEnergyCell, vertViscTopOf ! !----------------------------------------------------------------- - integer :: iEdge, nEdges, k, cell1, cell2, nVertLevels, N + integer :: iEdge, k, cell1, cell2, N + integer, pointer :: nEdges, nVertLevels integer, dimension(:), pointer :: maxLevelEdgeTop @@ -214,40 +228,45 @@ subroutine ocn_vel_vmix_tend_implicit(mesh, dt, kineticEnergyCell, vertViscTopOf real (kind=RKIND), dimension(:), allocatable :: A, B, C, velTemp + real (kind=RKIND), pointer :: config_bottom_drag_coeff + err = 0 if(.not.velVmixOn) return - nEdges = mesh % nEdges - nVertLevels = mesh % nVertLevels - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - cellsOnEdge => mesh % cellsOnEdge % array + call mpas_pool_get_config(ocnConfigs, 'config_bottom_drag_coeff', config_bottom_drag_coeff) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) allocate(A(nVertLevels),B(nVertLevels),C(nVertLevels),velTemp(nVertLevels)) A(1)=0 - do iEdge=1,nEdges - N=maxLevelEdgeTop(iEdge) - if (N.gt.0) then + do iEdge = 1, nEdges + N = maxLevelEdgeTop(iEdge) + if (N .gt. 0) then ! Compute A(k), B(k), C(k) ! layerThicknessEdge is computed in compute_solve_diag, and is not available yet, ! so recompute layerThicknessEdge here. cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - do k=1,N + do k = 1, N layerThicknessEdge(k,iEdge) = 0.5 * (layerThickness(k,cell1) + layerThickness(k,cell2)) end do ! A is lower diagonal term - do k=2,N + do k = 2, N A(k) = -2.0*dt*vertViscTopOfEdge(k,iEdge) & / (layerThicknessEdge(k-1,iEdge) + layerThicknessEdge(k,iEdge)) & / layerThicknessEdge(k,iEdge) enddo ! C is upper diagonal term - do k=1,N-1 + do k = 1, N-1 C(k) = -2.0*dt*vertViscTopOfEdge(k+1,iEdge) & / (layerThicknessEdge(k,iEdge) + layerThicknessEdge(k+1,iEdge)) & / layerThicknessEdge(k,iEdge) @@ -255,14 +274,14 @@ subroutine ocn_vel_vmix_tend_implicit(mesh, dt, kineticEnergyCell, vertViscTopOf ! B is diagonal term B(1) = 1 - C(1) - do k=2,N-1 + do k = 2, N-1 B(k) = 1 - A(k) - C(k) enddo ! Apply bottom drag boundary condition on the viscous term ! second line uses sqrt(2.0*kineticEnergyEdge(k,iEdge)) B(N) = 1 - A(N) + dt*config_bottom_drag_coeff & - *sqrt(kineticEnergyCell(k,cell1) + kineticEnergyCell(k,cell2))/layerThicknessEdge(k,iEdge) + * sqrt(kineticEnergyCell(k,cell1) + kineticEnergyCell(k,cell2)) / layerThicknessEdge(k,iEdge) call tridiagonal_solve(A(2:N),B,C(1:N-1),normalVelocity(:,iEdge),velTemp,N) @@ -291,7 +310,7 @@ end subroutine ocn_vel_vmix_tend_implicit!}}} ! !----------------------------------------------------------------------- - subroutine ocn_tracer_vmix_tend_implicit(mesh, dt, vertDiffTopOfCell, layerThickness, tracers, err)!{{{ + subroutine ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerThickness, tracers, err)!{{{ !----------------------------------------------------------------- ! @@ -299,8 +318,8 @@ subroutine ocn_tracer_vmix_tend_implicit(mesh, dt, vertDiffTopOfCell, layerThick ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & vertDiffTopOfCell !< Input: vertical mixing coefficients @@ -334,7 +353,8 @@ subroutine ocn_tracer_vmix_tend_implicit(mesh, dt, vertDiffTopOfCell, layerThick ! !----------------------------------------------------------------- - integer :: iCell, nCells, k, nVertLevels, num_tracers, N + integer :: iCell, k, num_tracers, N + integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelCell @@ -345,33 +365,34 @@ subroutine ocn_tracer_vmix_tend_implicit(mesh, dt, vertDiffTopOfCell, layerThick if(.not.tracerVmixOn) return - nCells = mesh % nCells - nVertLevels = mesh % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) num_tracers = size(tracers, dim=1) - maxLevelCell => mesh % maxLevelCell % array + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) allocate(A(nVertLevels),B(nVertLevels),C(nVertLevels),tracersTemp(num_tracers,nVertLevels)) - do iCell=1,nCells + do iCell = 1, nCells ! Compute A(k), B(k), C(k) for tracers N = maxLevelCell(iCell) ! A is lower diagonal term A(1)=0 - do k=2,N + do k = 2, N A(k) = -2.0*dt*vertDiffTopOfCell(k,iCell) & / (layerThickness(k-1,iCell) + layerThickness(k,iCell)) / layerThickness(k,iCell) enddo ! C is upper diagonal term - do k=1,N-1 + do k = 1, N-1 C(k) = -2.0*dt*vertDiffTopOfCell(k+1,iCell) & / (layerThickness(k,iCell) + layerThickness(k+1,iCell)) / layerThickness(k,iCell) enddo C(N) = 0.0 ! B is diagonal term - do k=1,N + do k = 1, N B(k) = 1 - A(k) - C(k) enddo @@ -402,43 +423,74 @@ end subroutine ocn_tracer_vmix_tend_implicit!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vmix_implicit(dt, mesh, diagnostics, state, err)!{{{ + subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, timeLevelIn)!{{{ real (kind=RKIND), intent(in) :: dt - type (mesh_type), intent(in) :: mesh - type (diagnostics_type), intent(inout) :: diagnostics - type (state_type), intent(inout) :: state + type (mpas_pool_type), intent(in) :: meshPool + type (mpas_pool_type), intent(inout) :: diagnosticsPool + type (mpas_pool_type), intent(inout) :: statePool integer, intent(out) :: err + integer, intent(in), optional :: timeLevelIn - integer :: nCells + integer :: timeLevel, k, cell1, cell2, iEdge + integer, pointer :: nCells, nEdges real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, layerThickness, layerThicknessEdge, vertViscTopOfEdge, vertDiffTopOfCell, kineticEnergyCell + real (kind=RKIND), dimension(:,:), pointer :: vertViscTopOfCell real (kind=RKIND), dimension(:,:,:), pointer :: tracers - integer, dimension(:), pointer :: maxLevelCell + integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop + integer, dimension(:,:), pointer :: cellsOnEdge + logical, pointer :: config_use_cvmix err = 0 - normalVelocity => state % normalVelocity % array - tracers => state % tracers % array - layerThickness => state % layerThickness % array - kineticEnergyCell => diagnostics % kineticEnergyCell % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array - vertViscTopOfEdge => diagnostics % vertViscTopOfEdge % array - vertDiffTopOfCell => diagnostics % vertDiffTopOfCell % array - maxLevelCell => mesh % maxLevelCell % array + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix', config_use_cvmix) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + + call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfEdge', vertViscTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfCell', vertViscTopOfCell) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - nCells = mesh % nCells + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call ocn_vmix_coefs(mesh, state, diagnostics, err) + call ocn_vmix_coefs(meshPool, statePool, diagnosticsPool, err, timeLevel) + + ! if using CVMix, then viscosity has to be averaged from cell centers to cell edges + if ( config_use_cvmix ) then + vertViscTopOfEdge(:,:) = 0.0 + do iEdge=1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + do k=1,maxLevelEdgeTop(iEdge) + vertViscTopOfEdge(k,iEdge) = 0.5*(vertViscTopOfCell(k,cell2)+vertViscTopOfCell(k,cell1)) + enddo + enddo + endif ! ! Implicit vertical solve for momentum ! - call ocn_vel_vmix_tend_implicit(mesh, dt, kineticEnergyCell, vertViscTopOfEdge, layerThickness, layerThicknessEdge, normalVelocity, err) + call ocn_vel_vmix_tend_implicit(meshPool, dt, kineticEnergyCell, vertViscTopOfEdge, layerThickness, layerThicknessEdge, normalVelocity, err) ! ! Implicit vertical solve for tracers ! - call ocn_tracer_vmix_tend_implicit(mesh, dt, vertDiffTopOfCell, layerThickness, tracers, err) + call ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerThickness, tracers, err) end subroutine ocn_vmix_implicit!}}} @@ -455,7 +507,6 @@ end subroutine ocn_vmix_implicit!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vmix_init(domain, err)!{{{ !-------------------------------------------------------------------- @@ -470,89 +521,115 @@ subroutine ocn_vmix_init(domain, err)!{{{ integer, intent(out) :: err !< Output: error flag - integer :: err1, err2, err3, err4 + integer :: err_tmp + logical, pointer :: config_disable_vel_vmix, config_disable_tr_vmix err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_vmix', config_disable_vel_vmix) + call mpas_pool_get_config(ocnConfigs, 'config_disable_tr_vmix', config_disable_tr_vmix) + velVmixOn = .true. tracerVmixOn = .true. if(config_disable_vel_vmix) velVmixOn = .false. if(config_disable_tr_vmix) tracerVmixOn = .false. - call ocn_vmix_coefs_const_init(err1) - call ocn_vmix_coefs_tanh_init(err2) - call ocn_vmix_coefs_rich_init(err3) - call ocn_vmix_cvmix_init(domain,err4) - - err = ior(err1, err2) - err = ior(err, err3) - err = ior(err, err4) + call ocn_vmix_coefs_const_init(err_tmp) + err = ior(err, err_tmp) + call ocn_vmix_coefs_tanh_init(err_tmp) + err = ior(err, err_tmp) + call ocn_vmix_coefs_rich_init(err_tmp) + err = ior(err, err_tmp) + call ocn_vmix_cvmix_init(domain,err_tmp) + err = ior(err, err_tmp) + call ocn_vmix_coefs_redi_init(err_tmp) + err = ior(err, err_tmp) write(6,*) 'ocn_vmix_init complete' !-------------------------------------------------------------------- end subroutine ocn_vmix_init!}}} -subroutine tridiagonal_solve(a,b,c,r,x,n)!{{{ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Solve the matrix equation Ax=r for x, where A is tridiagonal. -! A is an nxn matrix, with: -! a sub-diagonal, filled from 1:n-1 (a(1) appears on row 2) -! b diagonal, filled from 1:n -! c sup-diagonal, filled from 1:n-1 (c(1) apears on row 1) +!*********************************************************************** ! -! Input: a,b,c,r,n +! routine tridiagonal_solve ! -! Output: x -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - implicit none +!> \brief Solve the matrix equation Ax=r for x, where A is tridiagonal. +!> \author Mark Petersen +!> \date September 2011 +!> \details +!> Solve the matrix equation Ax=r for x, where A is tridiagonal. +!> A is an nxn matrix, with: +!> a sub-diagonal, filled from 1:n-1 (a(1) appears on row 2) +!> b diagonal, filled from 1:n +!> c sup-diagonal, filled from 1:n-1 (c(1) apears on row 1) +! +!----------------------------------------------------------------------- + subroutine tridiagonal_solve(a,b,c,r,x,n) !{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- - integer,intent(in) :: n - real (KIND=RKIND), dimension(n), intent(in) :: a,b,c,r - real (KIND=RKIND), dimension(n), intent(out) :: x - real (KIND=RKIND), dimension(n) :: bTemp,rTemp - real (KIND=RKIND) :: m - integer i + integer,intent(in) :: n + real (KIND=RKIND), dimension(n), intent(in) :: a,b,c,r - call mpas_timer_start("tridiagonal_solve") - - ! Use work variables for b and r - bTemp(1) = b(1) - rTemp(1) = r(1) - - ! First pass: set the coefficients - do i = 2,n - m = a(i-1)/bTemp(i-1) - bTemp(i) = b(i) - m*c(i-1) - rTemp(i) = r(i) - m*rTemp(i-1) - end do - - x(n) = rTemp(n)/bTemp(n) - ! Second pass: back-substition - do i = n-1, 1, -1 - x(i) = (rTemp(i) - c(i)*x(i+1))/bTemp(i) - end do + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- - call mpas_timer_stop("tridiagonal_solve") - -end subroutine tridiagonal_solve!}}} + real (KIND=RKIND), dimension(n), intent(out) :: x -subroutine tridiagonal_solve_mult(a,b,c,r,x,n,nDim,nSystems)!{{{ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Solve the matrix equation Ax=r for x, where A is tridiagonal. -! A is an nxn matrix, with: -! a sub-diagonal, filled from 1:n-1 (a(1) appears on row 2) -! b diagonal, filled from 1:n -! c sup-diagonal, filled from 1:n-1 (c(1) apears on row 1) + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + real (KIND=RKIND), dimension(n) :: bTemp,rTemp + real (KIND=RKIND) :: m + integer i + + ! Use work variables for b and r + bTemp(1) = b(1) + rTemp(1) = r(1) + + ! First pass: set the coefficients + do i = 2,n + m = a(i-1)/bTemp(i-1) + bTemp(i) = b(i) - m*c(i-1) + rTemp(i) = r(i) - m*rTemp(i-1) + end do + + x(n) = rTemp(n)/bTemp(n) + ! Second pass: back-substition + do i = n-1, 1, -1 + x(i) = (rTemp(i) - c(i)*x(i+1))/bTemp(i) + end do + + end subroutine tridiagonal_solve !}}} + +!*********************************************************************** ! -! Input: a,b,c,r,n +! routine tridiagonal_solve_mult ! -! Output: x -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - implicit none +!> \brief Solve multiple matrix equations Ax=r for x, where A is tridiagonal. +!> \author Mark Petersen +!> \date September 2011 +!> \details +!> Solve the matrix equation Ax=r for x, where A is tridiagonal. +!> A is an nxn matrix, with: +!> a sub-diagonal, filled from 1:n-1 (a(1) appears on row 2) +!> b diagonal, filled from 1:n +!> c sup-diagonal, filled from 1:n-1 (c(1) apears on row 1) +! +!----------------------------------------------------------------------- +subroutine tridiagonal_solve_mult(a,b,c,r,x,n,nDim,nSystems)!{{{ integer,intent(in) :: n, nDim, nSystems real (KIND=RKIND), dimension(n), intent(in) :: a,b,c @@ -562,8 +639,6 @@ subroutine tridiagonal_solve_mult(a,b,c,r,x,n,nDim,nSystems)!{{{ real (KIND=RKIND), dimension(nSystems,n) :: rTemp real (KIND=RKIND) :: m integer i,j - - call mpas_timer_start("tridiagonal_solve_mult") ! Use work variables for b and r bTemp(1) = b(1) @@ -590,8 +665,6 @@ subroutine tridiagonal_solve_mult(a,b,c,r,x,n,nDim,nSystems)!{{{ end do end do - call mpas_timer_stop("tridiagonal_solve_mult") - end subroutine tridiagonal_solve_mult!}}} !*********************************************************************** diff --git a/src/core_ocean/mpas_ocn_vmix_coefs_const.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_const.F similarity index 81% rename from src/core_ocean/mpas_ocn_vmix_coefs_const.F rename to src/core_ocean/shared/mpas_ocn_vmix_coefs_const.F index 0d5ada2f90..980a5a581f 100644 --- a/src/core_ocean/mpas_ocn_vmix_coefs_const.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_const.F @@ -22,8 +22,8 @@ module ocn_vmix_coefs_const use mpas_grid_types - use mpas_configure use mpas_timer + use ocn_constants implicit none private @@ -75,7 +75,7 @@ module ocn_vmix_coefs_const ! !----------------------------------------------------------------------- - subroutine ocn_vmix_coefs_const_build(mesh, s, d, err)!{{{ + subroutine ocn_vmix_coefs_const_build(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ !----------------------------------------------------------------- ! @@ -83,8 +83,10 @@ subroutine ocn_vmix_coefs_const_build(mesh, s, d, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state pool !----------------------------------------------------------------- ! @@ -92,11 +94,11 @@ subroutine ocn_vmix_coefs_const_build(mesh, s, d, err)!{{{ ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - s !< Input/Output: state information + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state information - type (diagnostics_type), intent(inout) :: & - d !< Input/Output: diagnostic information + type (mpas_pool_type), intent(inout) :: & + diagnosticsPool !< Input/Output: diagnostic information !----------------------------------------------------------------- ! @@ -117,6 +119,8 @@ subroutine ocn_vmix_coefs_const_build(mesh, s, d, err)!{{{ real (kind=RKIND), dimension(:,:), pointer :: & vertViscTopOfEdge, vertDiffTopOfCell + integer :: timeLevel + !----------------------------------------------------------------- ! ! call relevant routines for computing tendencies @@ -127,11 +131,17 @@ subroutine ocn_vmix_coefs_const_build(mesh, s, d, err)!{{{ err = 0 - vertViscTopOfEdge => d % vertViscTopOfEdge % array - vertDiffTopOfCell => d % vertDiffTopOfCell % array + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if - call ocn_vel_vmix_coefs_const(mesh, vertViscTopOfEdge, err1) - call ocn_tracer_vmix_coefs_const(mesh, vertDiffTopOfCell, err2) + call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfEdge', vertViscTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + + call ocn_vel_vmix_coefs_const(meshPool, vertViscTopOfEdge, err1) + call ocn_tracer_vmix_coefs_const(meshPool, vertDiffTopOfCell, err2) err = ior(err1, err2) @@ -151,7 +161,7 @@ end subroutine ocn_vmix_coefs_const_build!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vel_vmix_coefs_const(mesh, vertViscTopOfEdge, err)!{{{ + subroutine ocn_vel_vmix_coefs_const(meshPool, vertViscTopOfEdge, err)!{{{ !----------------------------------------------------------------- ! @@ -159,8 +169,8 @@ subroutine ocn_vel_vmix_coefs_const(mesh, vertViscTopOfEdge, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -186,7 +196,7 @@ subroutine ocn_vel_vmix_coefs_const(mesh, vertViscTopOfEdge, err)!{{{ err = 0 - if(.not.constViscOn) return + if ( .not. constViscOn ) return vertViscTopOfEdge = vertViscTopOfEdge + constVisc @@ -206,7 +216,7 @@ end subroutine ocn_vel_vmix_coefs_const!}}} ! !----------------------------------------------------------------------- - subroutine ocn_tracer_vmix_coefs_const(mesh, vertDiffTopOfCell, err)!{{{ + subroutine ocn_tracer_vmix_coefs_const(meshPool, vertDiffTopOfCell, err)!{{{ !----------------------------------------------------------------- ! @@ -214,8 +224,8 @@ subroutine ocn_tracer_vmix_coefs_const(mesh, vertDiffTopOfCell, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -241,7 +251,7 @@ subroutine ocn_tracer_vmix_coefs_const(mesh, vertDiffTopOfCell, err)!{{{ err = 0 - if(.not.constDiffOn) return + if ( .not. constDiffOn ) return vertDiffTopOfCell = vertDiffTopOfCell + constDiff @@ -249,7 +259,6 @@ subroutine ocn_tracer_vmix_coefs_const(mesh, vertDiffTopOfCell, err)!{{{ end subroutine ocn_tracer_vmix_coefs_const!}}} - !*********************************************************************** ! ! routine ocn_vmix_coefs_const_init @@ -265,7 +274,6 @@ end subroutine ocn_tracer_vmix_coefs_const!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vmix_coefs_const_init(err)!{{{ !-------------------------------------------------------------------- @@ -278,8 +286,16 @@ subroutine ocn_vmix_coefs_const_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + real (kind=RKIND), pointer :: config_vert_visc, config_vert_diff + logical, pointer :: config_use_const_visc, config_use_const_diff + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_use_const_visc', config_use_const_visc) + call mpas_pool_get_config(ocnConfigs, 'config_use_const_diff', config_use_const_diff) + call mpas_pool_get_config(ocnConfigs, 'config_vert_visc', config_vert_visc) + call mpas_pool_get_config(ocnConfigs, 'config_vert_diff', config_vert_diff) + constViscOn = config_use_const_visc constDiffOn = config_use_const_diff constVisc = config_vert_visc diff --git a/src/core_ocean/shared/mpas_ocn_vmix_coefs_redi.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_redi.F new file mode 100644 index 0000000000..ef0b61de7e --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_redi.F @@ -0,0 +1,245 @@ +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_vmix_coefs_const +! +!> \brief MPAS ocean vertical mixing coefficients +!> \author Doug Jacobsen +!> \date 19 September 2011 +!> \version SVN:$Id:$ +!> \details +!> This module contains the routines for compounding +!> the Redi vertical mixing coefficients. +!> +! +!----------------------------------------------------------------------- + +module ocn_vmix_coefs_redi + + use mpas_grid_types + use mpas_configure + use mpas_timer + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + private :: ocn_tracer_vmix_coefs_redi + + public :: ocn_vmix_coefs_redi_build, & + ocn_vmix_coefs_redi_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + logical :: rediDiffOn + logical, pointer :: config_use_standardGM + real (kind=RKIND), pointer :: config_Redi_kappa + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_vmix_coefs_redi_build +! +!> \brief Computes coefficients for vertical mixing +!> \author Doug Jacobsen +!> \date 19 September 2011 +!> \version SVN:$Id$ +!> \details +!> This routine computes the vertical mixing coefficients for momentum +!> and tracers based user choices of mixing parameterization. +! +!----------------------------------------------------------------------- + + subroutine ocn_vmix_coefs_redi_build(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state pool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state information + + type (mpas_pool_type), intent(inout) :: & + diagnosticsPool !< Input/Output: diagnostic information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:), pointer :: & + vertDiffTopOfCell, k33 + + !----------------------------------------------------------------- + ! + ! call relevant routines for computing tendencies + ! note that the user can choose multiple options and the + ! tendencies will be added together + ! + !----------------------------------------------------------------- + + err = 0 + + call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + call mpas_pool_get_array(diagnosticsPool, 'k33',k33) + + if (config_use_standardGM) then + call ocn_tracer_vmix_coefs_redi(meshPool, vertDiffTopOfCell, k33, err) + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_vmix_coefs_redi_build!}}} + +!*********************************************************************** +! +! routine ocn_tracer_vmix_coefs_redi +! +!> \brief Computes coefficients for vertical tracer mixing +!> \author Doug Jacobsen +!> \date 19 September 2011 +!> \version SVN:$Id$ +!> \details +!> This routine computes the rediant vertical mixing coefficients for tracers +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_vmix_coefs_redi(meshPool, vertDiffTopOfCell, vertRediDiff, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:), intent(inout) :: vertDiffTopOfCell !< Output: Vertical diffusion + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:), intent(in) :: vertRediDiff !< Output: Vertical diffusion + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + if(.not.rediDiffOn) return + + vertDiffTopOfCell = vertDiffTopOfCell + vertRediDiff + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_vmix_coefs_redi!}}} + + +!*********************************************************************** +! +! routine ocn_vmix_coefs_redi_init +! +!> \brief Initializes ocean momentum vertical mixing quantities +!> \author Doug Jacobsen +!> \date 19 September 2011 +!> \version SVN:$Id$ +!> \details +!> This routine initializes a variety of quantities related to +!> vertical velocity mixing in the ocean. Since a variety of +!> parameterizations are available, this routine primarily calls the +!> individual init routines for each parameterization. +! +!----------------------------------------------------------------------- + + + subroutine ocn_vmix_coefs_redi_init(err)!{{{ + + !-------------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! call individual init routines for each parameterization + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_standardGM',config_use_standardGM) + call mpas_pool_get_config(ocnConfigs, 'config_Redi_kappa',config_Redi_kappa) + + if (config_use_standardGM) then + rediDiffOn = .True. + else + rediDiffOn = .False. + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_vmix_coefs_redi_init!}}} + +!*********************************************************************** + +end module ocn_vmix_coefs_redi + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + +! vim: foldmethod=marker diff --git a/src/core_ocean/mpas_ocn_vmix_coefs_rich.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F similarity index 70% rename from src/core_ocean/mpas_ocn_vmix_coefs_rich.F rename to src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F index 7e8e475428..1d06ed208e 100644 --- a/src/core_ocean/mpas_ocn_vmix_coefs_rich.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F @@ -22,10 +22,10 @@ module ocn_vmix_coefs_rich use mpas_grid_types - use mpas_configure use mpas_constants use mpas_timer + use ocn_constants use ocn_equation_of_state implicit none @@ -73,7 +73,7 @@ module ocn_vmix_coefs_rich !> and tracers based user choices of mixing parameterization. ! !----------------------------------------------------------------------- - subroutine ocn_vmix_coefs_rich_build(mesh, state, diagnostics, err)!{{{ + subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ !----------------------------------------------------------------- ! @@ -81,8 +81,10 @@ subroutine ocn_vmix_coefs_rich_build(mesh, state, diagnostics, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state pool !----------------------------------------------------------------- ! @@ -90,11 +92,11 @@ subroutine ocn_vmix_coefs_rich_build(mesh, state, diagnostics, err)!{{{ ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - state !< Input/Output: state information + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state information - type (diagnostics_type), intent(inout) :: & - diagnostics !< Input/Output: diagnostic information + type (mpas_pool_type), intent(inout) :: & + diagnosticsPool !< Input/Output: diagnostic information !----------------------------------------------------------------- ! @@ -110,7 +112,8 @@ subroutine ocn_vmix_coefs_rich_build(mesh, state, diagnostics, err)!{{{ ! !----------------------------------------------------------------- - integer :: err1, err2, err3, indexT, indexS + integer :: err1, err2, err3, timeLevel + integer, pointer :: indexT, indexS real (kind=RKIND), dimension(:,:), pointer :: & vertViscTopOfEdge, vertDiffTopOfCell, normalVelocity, layerThickness, layerThicknessEdge, density, displacedDensity @@ -129,37 +132,43 @@ subroutine ocn_vmix_coefs_rich_build(mesh, state, diagnostics, err)!{{{ err = 0 - indexT = state % index_temperature - indexS = state % index_salinity + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_dimension(statePool, 'index_temperature', indexT) + call mpas_pool_get_dimension(statePool, 'index_salinity', indexS) - vertViscTopOfEdge => diagnostics % vertViscTopOfEdge % array - vertDiffTopOfCell => diagnostics % vertDiffTopOfCell % array - RiTopOfEdge => diagnostics % RiTopOfEdge % array - RiTopOfCell => diagnostics % RiTopOfCell % array - density => diagnostics % density % array - displacedDensity => diagnostics % displacedDensity % array - layerThicknessEdge => diagnostics % layerThicknessEdge % array + call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfEdge', vertViscTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + call mpas_pool_get_array(diagnosticsPool, 'RiTopOfEdge', RiTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'RiTopOfCell', RiTopOfCell) + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'displacedDensity', displacedDensity) + call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) - normalVelocity => state % normalVelocity % array - layerThickness => state % layerThickness % array - tracers => state % tracers % array + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) call mpas_timer_start("eos rich", .false., richEOSTimer) ! compute in-place density - call ocn_equation_of_state_density(state, diagnostics, mesh, 0, 'relative', density, err) + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 0, 'relative', density, err, timeLevelIn=timeLevel) ! compute displacedDensity, density displaced adiabatically to the mid-depth one layer deeper. ! That is, layer k has been displaced to the depth of layer k+1. - call ocn_equation_of_state_density(state, diagnostics, mesh, 1, 'relative', displacedDensity, err) + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 1, 'relative', displacedDensity, err, timeLevelIn=timeLevel) call mpas_timer_stop("eos rich", richEOSTimer) - call ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layerThickness, layerThicknessEdge, & + call ocn_vmix_get_rich_numbers(meshPool, indexT, indexS, normalVelocity, layerThickness, layerThicknessEdge, & density, displacedDensity, tracers, RiTopOfEdge, RiTopOfCell, err1) - call ocn_vel_vmix_coefs_rich(mesh, RiTopOfEdge, layerThicknessEdge, vertViscTopOfEdge, err2) - call ocn_tracer_vmix_coefs_rich(mesh, RiTopOfCell, layerThickness, vertDiffTopOfCell, err3) + call ocn_vel_vmix_coefs_rich(meshPool, RiTopOfEdge, layerThicknessEdge, vertViscTopOfEdge, err2) + call ocn_tracer_vmix_coefs_rich(meshPool, RiTopOfCell, layerThickness, vertDiffTopOfCell, err3) err = ior(err1, ior(err2, err3)) @@ -179,7 +188,7 @@ end subroutine ocn_vmix_coefs_rich_build!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vel_vmix_coefs_rich(mesh, RiTopOfEdge, layerThicknessEdge, vertViscTopOfEdge, err)!{{{ + subroutine ocn_vel_vmix_coefs_rich(meshPool, RiTopOfEdge, layerThicknessEdge, vertViscTopOfEdge, err)!{{{ !----------------------------------------------------------------- ! @@ -187,8 +196,8 @@ subroutine ocn_vel_vmix_coefs_rich(mesh, RiTopOfEdge, layerThicknessEdge, vertVi ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge !< Input: thickness at edge @@ -218,20 +227,27 @@ subroutine ocn_vel_vmix_coefs_rich(mesh, RiTopOfEdge, layerThicknessEdge, vertVi ! !----------------------------------------------------------------- - integer :: iEdge, nEdges, k + integer :: iEdge, k + integer, pointer :: nEdges integer, dimension(:), pointer :: maxLevelEdgeTop + real (kind=RKIND), pointer :: config_rich_mix, config_bkrd_vert_visc, config_convective_visc + err = 0 if(.not.richViscOn) return - nEdges = mesh % nEdges + call mpas_pool_get_config(ocnConfigs, 'config_rich_mix', config_rich_mix) + call mpas_pool_get_config(ocnConfigs, 'config_bkrd_vert_visc', config_bkrd_vert_visc) + call mpas_pool_get_config(ocnConfigs, 'config_convective_visc', config_convective_visc) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) - do iEdge = 1,nEdges - do k = 2,maxLevelEdgeTop(iEdge) + do iEdge = 1, nEdges + do k = 2, maxLevelEdgeTop(iEdge) ! efficiency note: these if statements are inside iEdge and k loops. ! Perhaps there is a more efficient way to do this. if (RiTopOfEdge(k,iEdge)>0.0) then @@ -264,7 +280,7 @@ end subroutine ocn_vel_vmix_coefs_rich!}}} ! !----------------------------------------------------------------------- - subroutine ocn_tracer_vmix_coefs_rich(mesh, RiTopOfCell, layerThickness, vertDiffTopOfCell, err)!{{{ + subroutine ocn_tracer_vmix_coefs_rich(meshPool, RiTopOfCell, layerThickness, vertDiffTopOfCell, err)!{{{ !----------------------------------------------------------------- ! @@ -272,8 +288,8 @@ subroutine ocn_tracer_vmix_coefs_rich(mesh, RiTopOfCell, layerThickness, vertDif ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & layerThickness !< Input: thickness at cell center @@ -303,23 +319,31 @@ subroutine ocn_tracer_vmix_coefs_rich(mesh, RiTopOfCell, layerThickness, vertDif ! !----------------------------------------------------------------- - integer :: iCell, nCells, k + integer :: iCell, k + integer, pointer :: nCells integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND) :: coef + real (kind=RKIND), pointer :: config_density0, config_bkrd_vert_diff, config_bkrd_vert_visc, config_rich_mix, config_convective_diff err = 0 if(.not.richDiffOn) return - nCells = mesh % nCells + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + call mpas_pool_get_config(ocnConfigs, 'config_bkrd_vert_diff', config_bkrd_vert_diff) + call mpas_pool_get_config(ocnConfigs, 'config_bkrd_vert_visc', config_bkrd_vert_visc) + call mpas_pool_get_config(ocnConfigs, 'config_rich_mix', config_rich_mix) + call mpas_pool_get_config(ocnConfigs, 'config_convective_diff', config_convective_diff) - maxLevelCell => mesh % maxLevelCell % array + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - coef = -gravity/config_density0/2.0 - do iCell = 1,nCells - do k = 2,maxLevelCell(iCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + coef = -gravity / config_density0 / 2.0 + do iCell = 1, nCells + do k = 2, maxLevelCell(iCell) ! efficiency note: these if statements are inside iEdge and k loops. ! Perhaps there is a more efficient way to do this. if (RiTopOfCell(k,iCell)>0.0) then @@ -355,7 +379,7 @@ end subroutine ocn_tracer_vmix_coefs_rich!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layerThickness, layerThicknessEdge, & !{{{ + subroutine ocn_vmix_get_rich_numbers(meshPool, indexT, indexS, normalVelocity, layerThickness, layerThicknessEdge, & !{{{ density, displacedDensity, tracers, RiTopOfEdge, RiTopOfCell, err) !----------------------------------------------------------------- @@ -364,8 +388,8 @@ subroutine ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layer ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information integer, intent(in) :: indexT !< Input: index for temperature integer, intent(in) :: indexS !< Input: index for salinity @@ -401,8 +425,9 @@ subroutine ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layer ! !----------------------------------------------------------------- - integer :: nVertLevels, nCells, nEdges, iCell, iEdge, k, i + integer :: iCell, iEdge, k, i integer :: cell1, cell2 + integer, pointer :: nVertLevels, nCells, nEdges integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, nEdgesOnCell integer, dimension(:,:), pointer :: cellsOnEdge, edgesOncell, edgeSignOnCell @@ -412,24 +437,28 @@ subroutine ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layer real (kind=RKIND), dimension(:,:), allocatable :: ddensityTopOfCell, du2TopOfCell, & ddensityTopOfEdge, du2TopOfEdge + real (kind=RKIND), pointer :: config_density0 + err = 0 - if((.not.richViscOn) .and. (.not.richDiffOn)) return + if ( ( .not. richViscOn ) .and. ( .not. richDiffOn ) ) return + + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) - nVertLevels = mesh % nVertLevels - nCells = mesh % nCells - nEdges = mesh % nEdges + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - maxLevelCell => mesh % maxLevelCell % array - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - maxLevelEdgeBot => mesh % maxLevelEdgeBot % array - cellsOnEdge => mesh % cellsOnEdge % array - dvEdge => mesh % dvEdge % array - dcEdge => mesh % dcEdge % array - areaCell => mesh % areaCell % array - nEdgesOnCell => mesh % nEdgesOnCell % array - edgesOnCell => mesh % edgesOnCell % array - edgeSignOnCell => mesh % edgeSignOnCell % array + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) allocate( & ddensityTopOfCell(nVertLevels+1,nCells+1), ddensityTopOfEdge(nVertLevels+1,nEdges), & @@ -437,18 +466,18 @@ subroutine ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layer ! ddensityTopOfCell(k) = $\rho^*_{k-1}-\rho_k$, where $\rho^*$ has been adiabatically displaced to level k. ddensityTopOfCell = 0.0 - do iCell=1,nCells - do k=2,maxLevelCell(iCell) + do iCell = 1, nCells + do k = 2, maxLevelCell(iCell) ddensityTopOfCell(k,iCell) = displacedDensity(k-1,iCell) - density(k,iCell) end do end do ! interpolate ddensityTopOfCell to ddensityTopOfEdge ddensityTopOfEdge = 0.0 - do iEdge=1,nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - do k=2,maxLevelEdgeTop(iEdge) + do k = 2, maxLevelEdgeTop(iEdge) ddensityTopOfEdge(k,iEdge) = & (ddensityTopOfCell(k,cell1) + & ddensityTopOfCell(k,cell2))/2 @@ -457,8 +486,8 @@ subroutine ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layer ! du2TopOfEdge(k) = $u_{k-1}-u_k$ du2TopOfEdge=0.0 - do iEdge=1,nEdges - do k=2,maxLevelEdgeTop(iEdge) + do iEdge = 1, nEdges + do k = 2, maxLevelEdgeTop(iEdge) du2TopOfEdge(k,iEdge) = (normalVelocity(k-1,iEdge) - normalVelocity(k,iEdge))**2 end do end do @@ -479,12 +508,12 @@ subroutine ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layer ! compute RiTopOfEdge using ddensityTopOfEdge and du2TopOfEdge ! coef = -g/density_0/2 RiTopOfEdge = 0.0 - coef = -gravity/config_density0/2.0 - do iEdge = 1,nEdges - do k = 2,maxLevelEdgeTop(iEdge) - RiTopOfEdge(k,iEdge) = coef*ddensityTopOfEdge(k,iEdge) & - *(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) & - / (du2TopOfEdge(k,iEdge) + 1e-20) + coef = -gravity / config_density0 / 2.0 + do iEdge = 1, nEdges + do k = 2, maxLevelEdgeTop(iEdge) + RiTopOfEdge(k,iEdge) = coef * ddensityTopOfEdge(k,iEdge) & + * ( layerThicknessEdge(k-1,iEdge) + layerThicknessEdge(k,iEdge) ) & + / ( du2TopOfEdge(k,iEdge) + 1e-20 ) end do end do @@ -493,8 +522,8 @@ subroutine ocn_vmix_get_rich_numbers(mesh, indexT, indexS, normalVelocity, layer RiTopOfCell = 0.0 do iCell = 1,nCells do k = 2,maxLevelCell(iCell) - RiTopOfCell(k,iCell) = coef*ddensityTopOfCell(k,iCell) & - *(layerThickness(k-1,iCell)+layerThickness(k,iCell)) & + RiTopOfCell(k,iCell) = coef * ddensityTopOfCell(k,iCell) & + * (layerThickness(k-1,iCell) + layerThickness(k,iCell)) & / (du2TopOfCell(k,iCell) + 1e-20) end do end do @@ -534,8 +563,13 @@ subroutine ocn_vmix_coefs_rich_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_use_rich_visc, config_use_rich_diff + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_use_rich_visc', config_use_rich_visc) + call mpas_pool_get_config(ocnConfigs, 'config_use_rich_diff', config_use_rich_diff) + richViscOn = config_use_rich_visc richDiffOn = config_use_rich_diff diff --git a/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F similarity index 69% rename from src/core_ocean/mpas_ocn_vmix_coefs_tanh.F rename to src/core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F index 13f790fc16..58aa4e6b24 100644 --- a/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F @@ -22,8 +22,8 @@ module ocn_vmix_coefs_tanh use mpas_grid_types - use mpas_configure use mpas_timer + use ocn_constants implicit none private @@ -69,7 +69,8 @@ module ocn_vmix_coefs_tanh ! !----------------------------------------------------------------------- - subroutine ocn_vmix_coefs_tanh_build(mesh, s, d, err)!{{{ + ! DWJ-POOL -- Remove Statepool? + subroutine ocn_vmix_coefs_tanh_build(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ !----------------------------------------------------------------- ! @@ -77,8 +78,9 @@ subroutine ocn_vmix_coefs_tanh_build(mesh, s, d, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + integer, intent(in), optional :: timeLevelIn !----------------------------------------------------------------- ! @@ -86,11 +88,11 @@ subroutine ocn_vmix_coefs_tanh_build(mesh, s, d, err)!{{{ ! !----------------------------------------------------------------- - type (state_type), intent(inout) :: & - s !< Input/Output: state information + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state information - type (diagnostics_type), intent(inout) :: & - d !< Input/Output: diagnostic information + type (mpas_pool_type), intent(inout) :: & + diagnosticsPool !< Input/Output: diagnostic information !----------------------------------------------------------------- ! @@ -106,7 +108,7 @@ subroutine ocn_vmix_coefs_tanh_build(mesh, s, d, err)!{{{ ! !----------------------------------------------------------------- - integer :: err1, err2 + integer :: err1, err2, timeLevel real (kind=RKIND), dimension(:,:), pointer :: & vertViscTopOfEdge, vertDiffTopOfCell @@ -121,11 +123,17 @@ subroutine ocn_vmix_coefs_tanh_build(mesh, s, d, err)!{{{ err = 0 - vertViscTopOfEdge => d % vertViscTopOfEdge % array - vertDiffTopOfCell => d % vertDiffTopOfCell % array + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if - call ocn_vel_vmix_coefs_tanh(mesh, vertViscTopOfEdge, err1) - call ocn_tracer_vmix_coefs_tanh(mesh, vertDiffTopOfCell, err2) + call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfEdge', vertViscTopOfEdge) + call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + + call ocn_vel_vmix_coefs_tanh(meshPool, vertViscTopOfEdge, err1) + call ocn_tracer_vmix_coefs_tanh(meshPool, vertDiffTopOfCell, err2) err = ior(err1, err2) @@ -145,7 +153,7 @@ end subroutine ocn_vmix_coefs_tanh_build!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vel_vmix_coefs_tanh(mesh, vertViscTopOfEdge, err)!{{{ + subroutine ocn_vel_vmix_coefs_tanh(meshPool, vertViscTopOfEdge, err)!{{{ !----------------------------------------------------------------- ! @@ -153,8 +161,8 @@ subroutine ocn_vel_vmix_coefs_tanh(mesh, vertViscTopOfEdge, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -178,25 +186,33 @@ subroutine ocn_vel_vmix_coefs_tanh(mesh, vertViscTopOfEdge, err)!{{{ ! !----------------------------------------------------------------- - integer :: k, nVertLevels + integer :: k + integer, pointer :: nVertLevels real (kind=RKIND), dimension(:), pointer :: refBottomDepth + real (kind=RKIND), pointer :: config_max_visc_tanh, config_min_visc_tanh, config_ZMid_tanh + real (kind=RKIND), pointer :: config_zWidth_tanh err = 0 if(.not.tanhViscOn) return - nVertLevels = mesh % nVertLevels - refBottomDepth => mesh % refBottomDepth % array + call mpas_pool_get_config(ocnConfigs, 'config_max_visc_tanh', config_max_visc_tanh) + call mpas_pool_get_config(ocnConfigs, 'config_min_visc_tanh', config_min_visc_tanh) + call mpas_pool_get_config(ocnConfigs, 'config_ZMid_tanh', config_ZMid_tanh) + call mpas_pool_get_config(ocnConfigs, 'config_zWidth_tanh', config_zWidth_tanh) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) ! 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. - do k=2,nVertLevels - 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 + do k = 2, nVertLevels + 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 @@ -216,7 +232,7 @@ end subroutine ocn_vel_vmix_coefs_tanh!}}} ! !----------------------------------------------------------------------- - subroutine ocn_tracer_vmix_coefs_tanh(mesh, vertDiffTopOfCell, err)!{{{ + subroutine ocn_tracer_vmix_coefs_tanh(meshPool, vertDiffTopOfCell, err)!{{{ !----------------------------------------------------------------- ! @@ -224,8 +240,8 @@ subroutine ocn_tracer_vmix_coefs_tanh(mesh, vertDiffTopOfCell, err)!{{{ ! !----------------------------------------------------------------- - type (mesh_type), intent(in) :: & - mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information !----------------------------------------------------------------- ! @@ -249,25 +265,34 @@ subroutine ocn_tracer_vmix_coefs_tanh(mesh, vertDiffTopOfCell, err)!{{{ ! !----------------------------------------------------------------- - integer :: k, nVertLevels + integer :: k + integer, pointer :: nVertLevels real (kind=RKIND), dimension(:), pointer :: refBottomDepth + real (kind=RKIND), pointer :: config_max_diff_tanh, config_min_diff_tanh, config_ZMid_tanh + real (kind=RKIND), pointer :: config_zWidth_tanh + err = 0 - if(.not.tanhDiffOn) return + if ( .not. tanhDiffOn ) return - nVertLevels = mesh % nVertLevels - refBottomDepth => mesh % refBottomDepth % array + call mpas_pool_get_config(ocnConfigs, 'config_max_diff_tanh', config_max_diff_tanh) + call mpas_pool_get_config(ocnConfigs, 'config_min_diff_tanh', config_min_diff_tanh) + call mpas_pool_get_config(ocnConfigs, 'config_ZMid_tanh', config_ZMid_tanh) + call mpas_pool_get_config(ocnConfigs, 'config_zWidth_tanh', config_zWidth_tanh) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) ! 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. do k=2,nVertLevels - 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 + 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 @@ -289,7 +314,6 @@ end subroutine ocn_tracer_vmix_coefs_tanh!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vmix_coefs_tanh_init(err)!{{{ !-------------------------------------------------------------------- @@ -302,8 +326,13 @@ subroutine ocn_vmix_coefs_tanh_init(err)!{{{ integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_use_tanh_visc, config_use_tanh_diff + err = 0 + call mpas_pool_get_config(ocnConfigs, 'config_use_tanh_visc', config_use_tanh_visc) + call mpas_pool_get_config(ocnConfigs, 'config_use_tanh_diff', config_use_tanh_diff) + tanhViscOn = config_use_tanh_visc tanhDiffOn = config_use_tanh_diff diff --git a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F new file mode 100644 index 0000000000..237e46e3b6 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F @@ -0,0 +1,725 @@ +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_vmix_cvmix +! +!> \brief MPAS ocean vertical mixing interface to CVMix +!> \author Todd Ringler +!> \date 04 February 2013 +!> \details +!> This module contains the routines for calls into CVMix +!> +! +!----------------------------------------------------------------------- + +module ocn_vmix_cvmix + + use mpas_grid_types + use mpas_timer + use mpas_io_units + + use ocn_constants + + use cvmix_kinds_and_types + use cvmix_put_get + use cvmix_background + use cvmix_ddiff + use cvmix_convection + use cvmix_shear + use cvmix_tidal + use cvmix_kpp + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_vmix_coefs_cvmix_build, & + ocn_vmix_cvmix_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + type(cvmix_global_params_type) :: cvmix_global_params + type(cvmix_bkgnd_params_type) :: cvmix_background_params + type(cvmix_shear_params_type) :: cvmix_shear_params + type(cvmix_tidal_params_type) :: cvmix_tidal_params + type(cvmix_data_type) :: cvmix_variables + + logical :: cvmixOn, cvmixBackgroundOn, cvmixConvectionOn, cvmixKPPOn + real (kind=RKIND) :: backgroundVisc, backgroundDiff + + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_vmix_coefs_cmvix_build +! +!> \brief Computes mixing coefficients using CVMix +!> \author Todd Ringler +!> \date 04 February 2013 +!> \details +!> This routine computes the vertical mixing coefficients for momentum +!> and tracers by calling CVMix routines. +! +!----------------------------------------------------------------------- + + subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in), optional :: timeLevelIn !< Input: time level for state pool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(inout) :: & + statePool !< Input/Output: state information + + type (mpas_pool_type), intent(inout) :: & + diagnosticsPool !< Input/Output: diagnostic information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer, dimension(:), pointer :: & + maxLevelCell + + real (kind=RKIND), dimension(:), pointer :: & + latCell, lonCell, bottomDepth, surfaceBuoyancyForcing, surfaceFrictionVelocity, fCell, & + boundaryLayerDepth, ssh, indexBoundaryLayerDepth + + real (kind=RKIND), dimension(:,:), pointer :: & + vertViscTopOfCell, vertDiffTopOfCell, layerThickness, & + zMid, zTop, density, displacedDensity, potentialDensity, & + bulkRichardsonNumber, RiTopOfCell, BruntVaisalaFreqTop, & + bulkRichardsonNumberBuoy, bulkRichardsonNumberShear + + real (kind=RKIND), dimension(:,:,:), pointer :: vertNonLocalFlux + integer, pointer :: index_vertNonLocalFluxTemp + + integer, pointer :: config_cvmix_kpp_niterate + logical, pointer :: config_use_cvmix_shear, config_use_cvmix_convection, config_use_cvmix_kpp + character (len=StrKIND), pointer :: config_cvmix_shear_mixing_scheme, config_cvmix_kpp_matching + + integer :: k, iCell, jCell, iNeighbor, iter, timeLevel + integer, pointer :: nVertLevels, nCells + real (kind=RKIND) :: r, layerSum + real (kind=RKIND), dimension(:), allocatable :: sigma, Nsqr_iface, turbulentScalarVelocityScale, tmp + real (kind=RKIND), dimension(:), allocatable, target :: RiSmoothed, BVFSmoothed + + real (kind=RKIND), pointer :: config_cvmix_background_viscosity, config_cvmix_background_diffusion + + !----------------------------------------------------------------- + ! + ! call relevant routines for computing mixing-related fields + ! note that the user can choose multiple options and the + ! mixing fields have to be added/merged together + ! + !----------------------------------------------------------------- + + ! + ! assume no errors during initialization and set to 1 when error is encountered + ! + err=0 + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + ! write(stdoutUnit,*) 'TDR: ocn_vmix_coefs_cvmix_build enter' + ! + ! only build up viscosity/diffusivity if CVMix is turned on + ! + if ( .not. cvmixOn ) return + + ! + ! set parameters + ! + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_background_viscosity', config_cvmix_background_viscosity) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_background_diffusion', config_cvmix_background_diffusion) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_niterate', config_cvmix_kpp_niterate) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_shear', config_use_cvmix_shear) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_convection', config_use_cvmix_convection) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_shear_mixing_scheme', config_cvmix_shear_mixing_scheme) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_matching', config_cvmix_kpp_matching) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + ! + ! set pointers for fields related to position on sphere + ! + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'fCell', fCell) + + ! + ! set pointers for fields related to vertical mesh + ! + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_array(statePool, 'ssh', ssh, timeLevel) + + call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + + ! + ! set pointers for fields related ocean state + ! + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'displacedDensity', displacedDensity) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', potentialDensity) + call mpas_pool_get_array(diagnosticsPool, 'bulkRichardsonNumber', bulkRichardsonNumber) + call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) + call mpas_pool_get_array(diagnosticsPool, 'RiTopOfCell', RiTopOfCell) + call mpas_pool_get_array(diagnosticsPool, 'BruntVaisalaFreqTop',BruntVaisalaFreqTop) + call mpas_pool_get_array(diagnosticsPool, 'bulkRichardsonNumberBuoy',bulkRichardsonNumberBuoy) + call mpas_pool_get_array(diagnosticsPool, 'bulkRichardsonNumberShear',bulkRichardsonNumberShear) + call mpas_pool_get_array(diagnosticsPool, 'indexBoundaryLayerDepth',indexBoundaryLayerDepth) + + ! + ! set pointers for fields related forcing at ocean surface + ! + call mpas_pool_get_array(diagnosticsPool, 'surfaceFrictionVelocity', surfaceFrictionVelocity) + call mpas_pool_get_array(diagnosticsPool, 'surfaceBuoyancyForcing', surfaceBuoyancyForcing) + + ! + ! set pointers for viscosity/diffusivity and intialize to zero + ! + call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfCell', vertViscTopOfCell) + call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + + vertViscTopOfCell = 0.0 + vertDiffTopOfCell = 0.0 + + ! + ! set pointers for nonlocal flux and intialize to zero + ! + call mpas_pool_get_array(diagnosticsPool, 'vertNonLocalFlux', vertNonLocalFlux) + call mpas_pool_get_dimension(diagnosticsPool, 'index_vertNonLocalFluxTemp', index_vertNonLocalFluxTemp) + + vertNonLocalFlux = 0.0 + + ! + ! start by adding the mininum background values to the visocity/diffusivity arrays + ! + if (cvmixBackgroundOn) then + vertViscTopOfCell(:,:) = vertViscTopOfCell(:,:) + config_cvmix_background_viscosity + vertDiffTopOfCell(:,:) = vertDiffTopOfCell(:,:) + config_cvmix_background_diffusion + endif + + ! + ! allocate selected cvmix variables and loop over columns + ! + cvmix_variables % max_nlev = nVertLevels + allocate(cvmix_variables % Mdiff_iface(nVertLevels+1)) + allocate(cvmix_variables % Tdiff_iface(nVertLevels+1)) + allocate(cvmix_variables % Sdiff_iface(nVertLevels+1)) + allocate(cvmix_variables % zw_iface(nVertLevels+1)) + allocate(cvmix_variables % dzw(nVertLevels+1)) + allocate(cvmix_variables % zt_cntr(nVertLevels)) + allocate(cvmix_variables % dzt(nVertLevels)) + allocate(cvmix_variables % kpp_Tnonlocal_iface(nVertLevels+1)) + allocate(cvmix_variables % kpp_Snonlocal_iface(nVertLevels+1)) + allocate(cvmix_variables % BulkRichardson_cntr(nVertLevels)) + + allocate(sigma(nVertLevels)) + allocate(Nsqr_iface(nVertLevels+1)) + allocate(turbulentScalarVelocityScale(nVertLevels)) + allocate(tmp(nVertLevels+1)) + allocate(RiSmoothed(nVertLevels+1)) + allocate(BVFSmoothed(nVertLevels+1)) + + do iCell = 1, nCells + + ! specify geometry/location + cvmix_variables % SeaSurfaceHeight = ssh(iCell) + cvmix_variables % Coriolis = fCell(iCell) + cvmix_variables % lat = latCell(iCell) * 180.0 / 3.14 + cvmix_variables % lon = lonCell(iCell) * 180.0 / 3.14 + + ! fill vertical position of column + ! CVMix assume top of ocean is at z=0, so building all z-coordinate data based on layerThickness + cvmix_variables % zw_iface(1) = 0.0 + cvmix_variables % dzw(1) = layerThickness(1,iCell)/2.0 + cvmix_variables % zt_cntr(1) = -layerThickness(1,iCell)/2.0 + do k=2,maxLevelCell(iCell) + cvmix_variables % zw_iface(k) = cvmix_variables % zw_iface(k-1) - layerThickness(k-1,iCell) + cvmix_variables % zt_cntr(k) = cvmix_variables % zw_iface(k) - layerThickness(k,iCell)/2.0 + cvmix_variables % dzw(k) = cvmix_variables % zt_cntr(k-1) - cvmix_variables % zt_cntr(k) + cvmix_variables % dzt(k) = layerThickness(k,iCell) + enddo + k = maxLevelCell(iCell)+1 + cvmix_variables % zw_iface(k) = cvmix_variables % zw_iface(k-1) - layerThickness(k-1,iCell) + cvmix_variables % dzw(k) = cvmix_variables % zt_cntr(k-1) - cvmix_variables % zw_iface(k) + do k = maxLevelCell(iCell) + 1, nVertLevels + cvmix_variables % zw_iface(k+1) = cvmix_variables % zw_iface(maxLevelCell(iCell)+1) + cvmix_variables % zt_cntr(k) = cvmix_variables % zw_iface(maxLevelCell(iCell)+1) + cvmix_variables % dzw(k+1) = 0.0 + cvmix_variables % dzt(k) = 0.0 + enddo + + ! fill the intent(in) convective adjustment + cvmix_variables % nlev = maxLevelCell(iCell) + cvmix_variables % OceanDepth = bottomDepth(iCell) + cvmix_variables % WaterDensity_cntr => density(:,iCell) + cvmix_variables % AdiabWaterDensity_cntr => displacedDensity(:,iCell) + + ! eliminate 2dz mode from Ri + RiSmoothed(1:nVertLevels) = RiTopOfCell(1:nVertLevels,iCell) + RiSmoothed(nVertLevels+1) = RiSmoothed(nVertLevels) + do k=2,maxLevelCell(iCell) + ! For input to cvmix, Richardson number should be positive. + tmp(k) = max(0.0, (RiSmoothed(k-1)+2*RiSmoothed(k)+RiSmoothed(k+1))/4.0 ) + enddo + k=1 + tmp(k)=tmp(k+1) + k=maxLevelCell(iCell)+1 + tmp(k:nVertLevels+1)=tmp(k-1) + RiSmoothed(:) = tmp(:) + cvmix_variables%ShearRichardson_iface => RiSmoothed + + ! eliminate 2dz mode from BVF + BVFSmoothed(1:nVertLevels) = BruntVaisalaFreqTop(1:nVertLevels,iCell) + BVFSmoothed(nVertLevels+1) = BVFSmoothed(nVertLevels) + do k=2,maxLevelCell(iCell) + tmp(k) = (BVFSmoothed(k-1)+2*BVFSmoothed(k)+BVFSmoothed(k+1))/4.0 + enddo + k=1 + tmp(k)=tmp(k+1) + k=maxLevelCell(iCell)+1 + tmp(k:nVertLevels+1)=tmp(k-1) + BVFSmoothed(:) = tmp(:) + cvmix_variables%SqrBuoyancyFreq_iface => BVFSmoothed + + ! fill the intent(in) KPP + cvmix_variables % SurfaceFriction = surfaceFrictionVelocity(iCell) + cvmix_variables % SurfaceBuoyancyForcing = surfaceBuoyancyForcing(iCell) + + ! call shear-based mixing scheme + if (config_use_cvmix_shear) then + cvmix_variables % Mdiff_iface(:)=0.0 + cvmix_variables % Tdiff_iface(:)=0.0 + call cvmix_coeffs_shear( & + cvmix_variables, & + cvmix_background_params, & + 1, & + .false., & + cvmix_shear_params) + + ! add shear mixing to vertical viscosity/diffusivity + ! at present, shear mixing adds in background values when using PP, but background is accounted for seperately. so remove background from shear mixing values + if(config_cvmix_shear_mixing_scheme=='PP') then + vertViscTopOfCell(:,iCell) = vertViscTopOfCell(:,iCell) + cvmix_variables % Mdiff_iface(:) - config_cvmix_background_viscosity + vertDiffTopOfCell(:,iCell) = vertDiffTopOfCell(:,iCell) + cvmix_variables % Tdiff_iface(:) - config_cvmix_background_diffusion + else + vertViscTopOfCell(:,iCell) = vertViscTopOfCell(:,iCell) + cvmix_variables % Mdiff_iface(:) + vertDiffTopOfCell(:,iCell) = vertDiffTopOfCell(:,iCell) + cvmix_variables % Tdiff_iface(:) + endif + + endif ! if (config_use_cvmix_shear) + + ! + ! put tidal mixing here + ! + + ! + ! put double diffusion mxing here + ! + + ! call kpp ocean mixed layer scheme + if (cvmixKPPOn) then + + ! copy data into cvmix_variables, then iterate + cvmix_variables % Mdiff_iface(:)=vertViscTopOfCell(:,iCell) + cvmix_variables % Tdiff_iface(:)=vertDiffTopOfCell(:,iCell) + cvmix_variables % BoundaryLayerDepth = boundaryLayerDepth(iCell) + cvmix_variables % kOBL_depth = cvmix_kpp_compute_kOBL_depth(cvmix_variables%zw_iface, cvmix_variables%zt_cntr, cvmix_variables%BoundaryLayerDepth) + + do iter=1,config_cvmix_kpp_niterate + + if(cvmix_variables % BoundaryLayerDepth .lt. layerThickness(1,iCell)/2.0) then + cvmix_variables % BoundaryLayerDepth = layerThickness(1,iCell)/2.0 + 0.01 + endif + + if(cvmix_variables % BoundaryLayerDepth .gt. abs(cvmix_variables%zw_iface(maxLevelCell(iCell)+1))) then + cvmix_variables % BoundaryLayerDepth = abs(cvmix_variables%zt_cntr(maxLevelCell(iCell))) + 0.01 + endif + + ! compute ocean boundary layer depth + do k=1,maxLevelCell(iCell) + sigma(k) = -cvmix_variables % zt_cntr(k) / cvmix_variables % BoundaryLayerDepth + Nsqr_iface(k) = BVFSmoothed(k) + enddo + k=maxLevelCell(iCell)+1 + sigma(k:nVertLevels) = sigma(k-1) + Nsqr_iface(k:nVertLevels+1) = Nsqr_iface(k-1) + + ! eliminate 2dz mode from N2 + tmp(:)=0.0 + do k=2,maxLevelCell(iCell) + tmp(k) = (Nsqr_iface(k-1)+2*Nsqr_iface(k)+Nsqr_iface(k+1))/4.0 + enddo + k=maxLevelCell(iCell)+1 + tmp(1)=tmp(2) + tmp(k:nVertLevels+1)=tmp(k-1) + Nsqr_iface(:)=tmp(:) + + ! compute the turbulent scales in order to compute the bulk Richardson number + call cvmix_kpp_compute_turbulent_scales( & + sigma(:), & + cvmix_variables % BoundaryLayerDepth, & + cvmix_variables % SurfaceBuoyancyForcing, & + cvmix_variables % SurfaceFriction, & + w_s = turbulentScalarVelocityScale(:) ) + + cvmix_variables % BulkRichardson_cntr = cvmix_kpp_compute_bulk_Richardson( & + cvmix_variables % zt_cntr(1:nVertLevels), & + bulkRichardsonNumberBuoy(1:nVertLevels,iCell), & + bulkRichardsonNumberShear(1:nVertLevels,iCell), & + ws_cntr = turbulentScalarVelocityScale(:), & + Nsqr_iface = Nsqr_iface(1:nVertLevels+1) ) + + ! compute the boundary layer depth based on model state at current time step + call cvmix_kpp_compute_OBL_depth( CVmix_vars = cvmix_variables) + + ! given current estimate of OBL and vertical profile of visc/diff, compute boundary layer mixing + call cvmix_coeffs_kpp( CVmix_vars = cvmix_variables ) + + end do ! iterate + + ! intent out of BoundaryLayerDepth is boundary layer depth measured in meters and vertical index + boundaryLayerDepth(iCell) = cvmix_variables % BoundaryLayerDepth + indexBoundaryLayerDepth(iCell) = cvmix_variables % kOBL_depth + bulkRichardsonNumber(:,iCell) = cvmix_variables % BulkRichardson_cntr(:) + + ! if using KPP with "MatchBoth" matching, then the output from KPP is the full viscosity/diffusivity + ! if using KPP with "SimpleShape" matching, then the output from KPP needs to be added to current viscosity/diffusivity + if(config_cvmix_kpp_matching.eq."MatchBoth") then + vertViscTopOfCell(:,iCell) = cvmix_variables % Mdiff_iface(:) + vertDiffTopOfCell(:,iCell) = cvmix_variables % Tdiff_iface(:) + elseif(config_cvmix_kpp_matching.eq."SimpleShapes") then + vertViscTopOfCell(:,iCell) = vertViscTopOfCell(:,iCell) + cvmix_variables % Mdiff_iface(:) + vertDiffTopOfCell(:,iCell) = vertDiffTopOfCell(:,iCell) + cvmix_variables % Tdiff_iface(:) + else + stop + endif + + ! store non-local flux terms + ! these flux terms must be multiplied by the surfaceTracerFlux field + ! the tracer tendency is then the vertical divergence of vertNonLocalFlux*surfaceTracerFlux + ! both of these operations are done in ocn_tracer_nonlocalflux_tend routine + vertNonLocalFlux(index_vertNonLocalFluxTemp,:,iCell) = cvmix_variables % kpp_Tnonlocal_iface(:) + + endif !if (config_use_cvmix_kpp) + + ! call convective mixing scheme + if (config_use_cvmix_convection) then + cvmix_variables % Mdiff_iface(:)=0.0 + cvmix_variables % Tdiff_iface(:)=0.0 + call cvmix_coeffs_conv( CVmix_vars = cvmix_variables ) + + ! add convective mixing to vertical viscosity/diffusivity + ! if using KPP, then do not apply convective mixing within the ocean boundary layer + if(config_use_cvmix_kpp) then + do k = int(indexBoundaryLayerDepth(iCell)) + 1, maxLevelCell(iCell) + vertViscTopOfCell(k,iCell) = vertViscTopOfCell(k,iCell) + cvmix_variables % Mdiff_iface(k) + vertDiffTopOfCell(k,iCell) = vertDiffTopOfCell(k,iCell) + cvmix_variables % Tdiff_iface(k) + enddo + else + vertViscTopOfCell(:,iCell) = vertViscTopOfCell(:,iCell) + cvmix_variables % Mdiff_iface(:) + vertDiffTopOfCell(:,iCell) = vertDiffTopOfCell(:,iCell) + cvmix_variables % Tdiff_iface(:) + endif + endif ! if (config_use_cvmix_convection) + + ! computation of viscosity/diffusivity complete + ! impose no-flux boundary conditions at top and bottom by zero viscosity/diffusivity + vertViscTopOfCell(1,iCell) = 0.0 + vertDiffTopOfCell(1,iCell) = 0.0 + vertViscTopOfCell(maxLevelCell(iCell)+1:nVertLevels,iCell)=0.0 + vertDiffTopOfCell(maxLevelCell(iCell)+1:nVertLevels,iCell)=0.0 + + end do ! do iCell=1,mesh%nCells + + ! dellocate cmvix variables + deallocate(cvmix_variables % Mdiff_iface) + deallocate(cvmix_variables % Tdiff_iface) + deallocate(cvmix_variables % zw_iface) + deallocate(cvmix_variables % dzw) + deallocate(cvmix_variables % zt_cntr) + deallocate(cvmix_variables % dzt) + deallocate(cvmix_variables % kpp_Tnonlocal_iface) + deallocate(cvmix_variables % BulkRichardson_cntr) + + deallocate(sigma) + deallocate(Nsqr_iface) + deallocate(turbulentScalarVelocityScale) + deallocate(tmp) + deallocate(RiSmoothed) + deallocate(BVFSmoothed) + + !-------------------------------------------------------------------- + + end subroutine ocn_vmix_coefs_cvmix_build!}}} + +!*********************************************************************** +! +! routine ocn_vmix_cvmix_init +! +!> \brief Initializes ocean vertical mixing quantities by using +!> \ get and puts into CVMix +!> \author Todd Ringler +!> \date 04 February 2013 +!> \details +!> This routine initializes a variety of quantities related to +!> vertical mixing in the ocean. Parameters are set by calling into CVMix +! +!----------------------------------------------------------------------- + + + subroutine ocn_vmix_cvmix_init(domain,err)!{{{ + + !-------------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! call individual init routines for each parameterization + ! + !----------------------------------------------------------------- + + implicit none + + type (domain_type), intent(inout) :: domain !< Input/Output: domain information + + integer, intent(out) :: err !< Output: error flag + + integer, pointer :: nVertLevels + type (block_type), pointer :: block + + ! CVMix + logical, pointer :: config_use_cvmix + + ! background + logical, pointer :: config_use_cvmix_background + real (kind=RKIND), pointer :: config_cvmix_background_viscosity, config_cvmix_background_diffusion + real (kind=RKIND), pointer :: config_cvmix_prandtl_number + + ! Shear configs + logical, pointer :: config_use_cvmix_shear + character (len=StrKIND), pointer :: config_cvmix_shear_mixing_scheme + real (kind=RKIND), pointer :: config_cvmix_shear_PP_nu_zero, config_cvmix_shear_PP_alpha, config_cvmix_shear_PP_exp, & + config_cvmix_shear_KPP_nu_zero, config_cvmix_shear_KPP_Ri_zero, config_cvmix_shear_KPP_exp + + ! Convection configs + logical, pointer :: config_use_cvmix_convection + real (kind=RKIND), pointer :: config_cvmix_convective_diffusion, config_cvmix_convective_viscosity, config_cvmix_convective_triggerBVF + logical, pointer :: config_cvmix_convective_basedOnBVF + + ! Tidal mixing + logical, pointer :: config_use_cvmix_tidal_mixing + + ! Double diffusion + logical, pointer :: config_use_cvmix_double_diffusion + + ! KPP configs + logical, pointer :: config_use_cvmix_kpp + character (len=StrKIND), pointer :: config_cvmix_kpp_matching, config_cvmix_kpp_interpolationOMLType + logical, pointer :: config_cvmix_kpp_EkmanOBL, config_cvmix_kpp_MonObOBL + real (kind=RKIND), pointer :: config_cvmix_kpp_criticalBulkRichardsonNumber, & + config_cvmix_kpp_surface_layer_extent + ! + ! assume no errors during initialization and set to 1 when error is encountered + ! + err=0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix', config_use_cvmix) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_background', config_use_cvmix_background) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_background_viscosity', config_cvmix_background_viscosity) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_background_diffusion', config_cvmix_background_diffusion) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_shear', config_use_cvmix_shear) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_shear_mixing_scheme', config_cvmix_shear_mixing_scheme) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_shear_PP_nu_zero', config_cvmix_shear_PP_nu_zero) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_shear_PP_alpha', config_cvmix_shear_PP_alpha) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_shear_PP_exp', config_cvmix_shear_PP_exp) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_shear_KPP_nu_zero', config_cvmix_shear_KPP_nu_zero) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_shear_KPP_Ri_zero', config_cvmix_shear_KPP_Ri_zero) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_shear_KPP_exp', config_cvmix_shear_KPP_exp) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_convection', config_use_cvmix_convection) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_convective_basedOnBVF', config_cvmix_convective_basedOnBVF) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_convective_triggerBVF', config_cvmix_convective_triggerBVF) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_tidal_mixing', config_use_cvmix_tidal_mixing) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_double_diffusion', config_use_cvmix_double_diffusion) + call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_criticalBulkRichardsonNumber', config_cvmix_kpp_criticalBulkRichardsonNumber) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_interpolationOMLType', config_cvmix_kpp_interpolationOMLType) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_interpolationOMLType', config_cvmix_kpp_interpolationOMLType) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_EkmanOBL', config_cvmix_kpp_EkmanOBL) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_MonObOBL', config_cvmix_kpp_MonObOBL) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_matching', config_cvmix_kpp_matching) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_surface_layer_extent', config_cvmix_kpp_surface_layer_extent) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_prandtl_number', config_cvmix_prandtl_number) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_convective_diffusion', config_cvmix_convective_diffusion) + call mpas_pool_get_config(ocnConfigs, 'config_cvmix_convective_viscosity', config_cvmix_convective_viscosity) + + cvmixOn = config_use_cvmix + cvmixBackgroundOn = config_use_cvmix_background + backgroundVisc = config_cvmix_background_viscosity + backgroundDiff = config_cvmix_background_diffusion + cvmixConvectionOn = config_use_cvmix_convection + cvmixKPPOn = config_use_cvmix_kpp + + ! + ! only initialize if CVMix is turned on + ! + if (.not.config_use_cvmix) return + + ! + ! When CVMix is turned on, all other vertical mixing schemes should be off + ! Test to make sure this is the case. + ! + ! test here, err=1 if a problem + + ! + ! pull nVertLevels out of the mesh structure + ! + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevels', nVertLevels) + + ! + ! put global parameters into CVMix + ! + call cvmix_put(cvmix_global_params, 'max_nlev', nVertLevels) + call cvmix_put(cvmix_global_params, 'prandtl', config_cvmix_prandtl_number) + + ! + ! initialize background mixing + ! + if (config_use_cvmix_background .or. config_use_cvmix_shear) then + call cvmix_init_bkgnd( & + bkgnd_diff = config_cvmix_background_diffusion, & + bkgnd_visc = config_cvmix_background_viscosity, & + CVmix_bkgnd_params_user = cvmix_background_params) + endif + + ! + ! initialize shear-based mixing + ! + if (config_use_cvmix_shear) then + if (.not. config_use_cvmix_background .and. trim(config_cvmix_shear_mixing_scheme) == 'PP') then + write(stderrUnit, *) "ERROR: config_use_cvmix_shear cannot be used with with config_cvmix_shear_mixing_scheme = 'PP'" + write(stderrUnit, *) " without config_use_cvmix_background = .true." + err = 1 + return + end if + call cvmix_init_shear( & + cvmix_shear_params, & + mix_scheme = config_cvmix_shear_mixing_scheme, & + PP_nu_zero = config_cvmix_shear_PP_nu_zero, & + PP_alpha = config_cvmix_shear_PP_alpha, & + PP_exp = config_cvmix_shear_PP_exp, & + KPP_nu_zero = config_cvmix_shear_KPP_nu_zero, & + KPP_Ri_zero = config_cvmix_shear_KPP_Ri_zero, & + KPP_exp = config_cvmix_shear_KPP_exp) + endif + + ! + ! initialize convective mixing + ! + if (config_use_cvmix_convection) then + + ! config_cvmix_convective_basedOnBVF is not supported at this time + if (.not.config_cvmix_convective_basedOnBVF) then + write(stderrUnit, *) "ERROR: config_cvmix_convective_basedOnBVF = .false. is not supported. Change to true." + err = 1 + return + endif + + call cvmix_init_conv( & + convect_diff = config_cvmix_convective_diffusion, & + convect_visc = config_cvmix_convective_viscosity, & + lBruntVaisala = config_cvmix_convective_basedOnBVF, & + BVsqr_convect = config_cvmix_convective_triggerBVF ) + endif + + ! + ! initialize tidal mixing + ! (at present, tidal mixing can only use CVMix default parameter settings) + ! + if (config_use_cvmix_tidal_mixing) then + call cvmix_init_tidal(cvmix_tidal_params,'Simmons') + endif + + ! + ! initialize double diffusion + ! (at present, double diffusion can only use CVMix default parameter settings) + ! + if (config_use_cvmix_double_diffusion) then + call cvmix_init_ddiff( ) + endif + + ! + ! initialize KPP boundary layer scheme + ! + if (config_use_cvmix_kpp) then + call cvmix_init_kpp ( & + ri_crit = config_cvmix_kpp_criticalBulkRichardsonNumber, & + interp_type = config_cvmix_kpp_interpolationOMLType, & + interp_type2 = config_cvmix_kpp_interpolationOMLType, & + lEkman = config_cvmix_kpp_EkmanOBL, & + lMonOb = config_cvmix_kpp_MonObOBL, & + MatchTechnique = config_cvmix_kpp_matching, & + surf_layer_ext = config_cvmix_kpp_surface_layer_extent) + endif + + + !-------------------------------------------------------------------- + + end subroutine ocn_vmix_cvmix_init!}}} + +!*********************************************************************** + +end module ocn_vmix_cvmix + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/src/core_sw/Makefile b/src/core_sw/Makefile index 2a743dfde0..d25345eda6 100644 --- a/src/core_sw/Makefile +++ b/src/core_sw/Makefile @@ -2,27 +2,37 @@ OBJS = mpas_sw_mpas_core.o \ mpas_sw_test_cases.o \ - mpas_sw_advection.o \ - mpas_sw_time_integration.o \ - mpas_sw_global_diagnostics.o + mpas_sw_advection.o \ + mpas_sw_time_integration.o \ + mpas_sw_global_diagnostics.o \ + mpas_sw_constants.o all: core_sw core_sw: $(OBJS) ar -ru libdycore.a $(OBJS) -mpas_sw_test_cases.o: +core_reg: + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml -mpas_sw_advection.o: +mpas_sw_constants.o: -mpas_sw_time_integration.o: +mpas_sw_test_cases.o: mpas_sw_constants.o -mpas_sw_global_diagnostics.o: +mpas_sw_advection.o: mpas_sw_constants.o -mpas_sw_mpas_core.o: mpas_sw_global_diagnostics.o mpas_sw_test_cases.o mpas_sw_time_integration.o mpas_sw_advection.o +mpas_sw_time_integration.o: mpas_sw_constants.o + +mpas_sw_global_diagnostics.o: mpas_sw_constants.o + +mpas_sw_mpas_core.o: mpas_sw_global_diagnostics.o mpas_sw_test_cases.o mpas_sw_time_integration.o mpas_sw_advection.o mpas_sw_constants.o clean: $(RM) *.o *.mod *.f90 libdycore.a + $(RM) Registry_processed.xml + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: $(RM) $@ $*.mod diff --git a/src/core_sw/Registry.xml b/src/core_sw/Registry.xml index 94d81f7a8c..e63d883653 100644 --- a/src/core_sw/Registry.xml +++ b/src/core_sw/Registry.xml @@ -1,5 +1,5 @@ - + @@ -14,11 +14,11 @@ - + - + @@ -37,107 +37,292 @@ - - - - - - - + - + - + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - + + + + diff --git a/src/core_sw/mpas_sw_advection.F b/src/core_sw/mpas_sw_advection.F index 39049847e2..7ace09d5ad 100644 --- a/src/core_sw/mpas_sw_advection.F +++ b/src/core_sw/mpas_sw_advection.F @@ -16,7 +16,7 @@ module sw_advection contains - subroutine sw_initialize_advection_rk( grid ) + subroutine sw_initialize_advection_rk( meshPool ) ! ! compute the cell coefficients for the polynomial fit. @@ -25,16 +25,16 @@ subroutine sw_initialize_advection_rk( grid ) ! implicit none - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(in) :: meshPool real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two integer, dimension(:,:), pointer :: advCells ! local variables - real (kind=RKIND), dimension(2, grid % nEdges) :: thetae - real (kind=RKIND), dimension(grid % nEdges) :: xe, ye - real (kind=RKIND), dimension(grid % nCells) :: theta_abs + real (kind=RKIND), dimension(:,:), allocatable :: thetae + real (kind=RKIND), dimension(:), allocatable :: xe, ye + real (kind=RKIND), dimension(:), allocatable :: theta_abs real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere @@ -54,8 +54,8 @@ subroutine sw_initialize_advection_rk( grid ) integer :: ma,na, cell_add, mw, nn integer, dimension(25) :: cell_list - integer :: cell1, cell2 + integer, pointer :: maxEdges, nEdges, nCells integer, parameter :: polynomial_order = 2 ! logical, parameter :: debug = .true. logical, parameter :: debug = .false. @@ -66,28 +66,61 @@ subroutine sw_initialize_advection_rk( grid ) logical, parameter :: reset_poly = .true. real (kind=RKIND) :: rcell, cos2t, costsint, sin2t - real (kind=RKIND), dimension(grid%maxEdges) :: angle_2d + real (kind=RKIND), dimension(:), allocatable :: angle_2d + + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell, edgesOnCell, cellsOnEdge, verticesOnEdge + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, angleEdge + real (kind=RKIND), dimension(:), pointer :: dcEdge, xVertex, yVertex, zVertex !--- + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(meshPool, 'sphere_radius', sphere_radius) + + call mpas_pool_get_dimension(meshPool, 'maxEdges', maxEdges) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + allocate(angle_2d(maxEdges)) + allocate(thetae(2, nEdges)) + allocate(xe(nEdges)) + allocate(ye(nEdges)) + allocate(theta_abs(nCells)) + pii = 2.*asin(1.0) - advCells => grid % advCells % array - deriv_two => grid % deriv_two % array + call mpas_pool_get_array(meshPool, 'advCells', advCells) + call mpas_pool_get_array(meshPool, 'deriv_two', deriv_two) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) deriv_two(:,:,:) = 0. - do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also... + do iCell = 1, nCells ! is this correct? - we need first halo cell also... cell_list(1) = iCell - do i=2, grid % nEdgesOnCell % array(iCell)+1 - cell_list(i) = grid % CellsOnCell % array(i-1,iCell) + do i = 2, nEdgesOnCell(iCell)+1 + cell_list(i) = cellsOnCell(i-1,iCell) end do - n = grid % nEdgesOnCell % array(iCell) + 1 + n = nEdgesOnCell(iCell) + 1 if ( polynomial_order > 2 ) then - do i=2,grid % nEdgesOnCell % array(iCell) + 1 - do j=1,grid % nEdgesOnCell % array ( cell_list(i) ) - cell_add = grid % CellsOnCell % array (j,cell_list(i)) + do i = 2, nEdgesOnCell(iCell) + 1 + do j = 1, nEdgesOnCell( cell_list(i) ) + cell_add = CellsOnCell(j,cell_list(i)) add_the_cell = .true. do k=1,n if ( cell_add == cell_list(k) ) add_the_cell = .false. @@ -105,8 +138,8 @@ subroutine sw_initialize_advection_rk( grid ) ! check to see if we are reaching outside the halo do_the_cell = .true. - do i=1,n - if (cell_list(i) > grid % nCells) do_the_cell = .false. + do i = 1, n + if (cell_list(i) > nCells) do_the_cell = .false. end do @@ -114,13 +147,13 @@ subroutine sw_initialize_advection_rk( grid ) ! compute poynomial fit for this cell if all needed neighbors exist - if ( grid % on_a_sphere ) then + if ( on_a_sphere ) then - do i=1,n + 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) = xCell(advCells(i+1,iCell)) / sphere_radius + yc(i) = yCell(advCells(i+1,iCell)) / sphere_radius + zc(i) = zCell(advCells(i+1,iCell)) / sphere_radius end do theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), & @@ -129,7 +162,7 @@ subroutine sw_initialize_advection_rk( grid ) ! angles from cell center to neighbor centers (thetav) - do i=1,n-1 + do i = 1, n-1 ip2 = i+2 if (ip2 > n) ip2 = 2 @@ -143,8 +176,8 @@ subroutine sw_initialize_advection_rk( grid ) end do length_scale = 1. - do i=1,n-1 - dl_sphere(i) = dl_sphere(i)/length_scale + do i = 1, n-1 + dl_sphere(i) = dl_sphere(i) / length_scale end do ! thetat(1) = 0. ! this defines the x direction, cell center 1 -> @@ -160,18 +193,18 @@ subroutine sw_initialize_advection_rk( grid ) else ! On an x-y plane - do i=1,n-1 + do i = 1, n-1 - angle_2d(i) = grid%angleEdge%array(grid % EdgesOnCell % array(i,iCell)) - iEdge = grid % EdgesOnCell % array(i,iCell) - if ( iCell .ne. grid % CellsOnEdge % array(1,iEdge)) & + iEdge = edgesOnCell(i,iCell) + angle_2d(i) = angleEdge(iEdge) + if ( iCell .ne. cellsOnEdge(1,iEdge)) & angle_2d(i) = angle_2d(i) - pii ! xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell) ! yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell) - xp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * cos(angle_2d(i)) - yp(i) = grid % dcEdge % array(grid % EdgesOnCell % array(i,iCell)) * sin(angle_2d(i)) + xp(i) = dcEdge(iEdge) * cos(angle_2d(i)) + yp(i) = dcEdge(iEdge) * sin(angle_2d(i)) end do @@ -179,7 +212,7 @@ subroutine sw_initialize_advection_rk( grid ) ma = n-1 - mw = grid % nEdgesOnCell % array (iCell) + mw = nEdgesOnCell(iCell) bmatrix = 0. amatrix = 0. @@ -264,19 +297,19 @@ subroutine sw_initialize_advection_rk( grid ) call sw_poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 ) - do i=1,grid % nEdgesOnCell % array (iCell) + do i = 1, nEdgesOnCell(iCell) ip1 = i+1 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 + iEdge = edgesOnCell(i,iCell) + xv1 = xVertex(verticesOnEdge(1, iEdge)) / sphere_radius + yv1 = yVertex(verticesOnEdge(1, iEdge)) / sphere_radius + zv1 = zVertex(verticesOnEdge(1, iEdge)) / sphere_radius + xv2 = xVertex(verticesOnEdge(2, iEdge)) / sphere_radius + yv2 = yVertex(verticesOnEdge(2, iEdge)) / sphere_radius + zv2 = zVertex(verticesOnEdge(2, iEdge)) / sphere_radius - if ( grid % on_a_sphere ) then + if ( on_a_sphere ) then call sw_arc_bisect( xv1, yv1, zv1, & xv2, yv2, zv2, & xec, yec, zec ) @@ -285,15 +318,15 @@ subroutine sw_initialize_advection_rk( grid ) xc(i+1), yc(i+1), zc(i+1), & xec, yec, zec ) thetae_tmp = thetae_tmp + thetat(i) - if (iCell == grid % cellsOnEdge % array(1,iEdge)) then - thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp + if (iCell == cellsOnEdge(1,iEdge)) then + thetae(1, iEdge) = thetae_tmp else - thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp + thetae(2, iEdge) = thetae_tmp end if ! else ! -! xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2) -! ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2) +! xe(iEdge) = 0.5 * (xv1 + xv2) +! ye(iEdge) = 0.5 * (yv1 + yv2) end if @@ -301,28 +334,28 @@ subroutine sw_initialize_advection_rk( grid ) ! fill second derivative stencil for rk advection - do i=1, grid % nEdgesOnCell % array (iCell) - iEdge = grid % EdgesOnCell % array (i,iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) - if ( grid % on_a_sphere ) then - if (iCell == grid % cellsOnEdge % array(1,iEdge)) then + if ( on_a_sphere ) then + if (iCell == cellsOnEdge(1,iEdge)) then - cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell))) - sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell))) + cos2t = cos(thetae(1, iEdge)) + sin2t = sin(thetae(1, iEdge)) costsint = cos2t*sin2t cos2t = cos2t**2 sin2t = sin2t**2 - do j=1,n + do j = 1, n deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) & + 2.*costsint*bmatrix(5,j) & + 2.*sin2t*bmatrix(6,j) end do else - cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell))) - sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell))) + cos2t = cos(thetae(2, iEdge)) + sin2t = sin(thetae(2, iEdge)) costsint = cos2t*sin2t cos2t = cos2t**2 sin2t = sin2t**2 @@ -349,14 +382,14 @@ subroutine sw_initialize_advection_rk( grid ) ! + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j) ! end do - if (iCell == grid % cellsOnEdge % array(1,iEdge)) then - do j=1,n + if (iCell == cellsOnEdge(1,iEdge)) then + do j = 1, n deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) & + 2.*costsint*bmatrix(5,j) & + 2.*sin2t*bmatrix(6,j) end do else - do j=1,n + do j = 1, n deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) & + 2.*costsint*bmatrix(5,j) & + 2.*sin2t*bmatrix(6,j) @@ -750,7 +783,7 @@ end subroutine sw_elgs !------------------------------------------------------------- - subroutine sw_initialize_deformation_weights( grid ) + subroutine sw_initialize_deformation_weights( meshPool ) ! ! compute the cell coefficients for the deformation calculations @@ -758,16 +791,13 @@ subroutine sw_initialize_deformation_weights( grid ) ! implicit none - type (mesh_type), intent(in) :: grid - - real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b - integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell + type (mpas_pool_type), intent(in) :: meshPool ! local variables - real (kind=RKIND), dimension(2, grid % nEdges) :: thetae - real (kind=RKIND), dimension(grid % nEdges) :: xe, ye - real (kind=RKIND), dimension(grid % nCells) :: theta_abs + real (kind=RKIND), dimension(:,:), allocatable :: thetae + real (kind=RKIND), dimension(:), allocatable :: xe, ye + real (kind=RKIND), dimension(:), allocatable :: theta_abs real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere @@ -792,12 +822,41 @@ subroutine sw_initialize_deformation_weights( grid ) logical, parameter :: debug = .false. + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + + integer, pointer :: nCells, nEdges + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell + if (debug) write(0,*) ' in def weight calc ' - defc_a => grid % defc_a % array - defc_b => grid % defc_b % array - cellsOnEdge => grid % cellsOnEdge % array - edgesOnCell => grid % edgesOnCell % array + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(meshPool, 'sphere_radius', sphere_radius) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(meshPool, 'defc_a', defc_a) + call mpas_pool_get_array(meshPool, 'defc_b', defc_b) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + + allocate(thetae(2, nEdges)) + allocate(xe(nEdges)) + allocate(ye(nEdges)) + allocate(theta_abs(nCells)) defc_a(:,:) = 0. defc_b(:,:) = 0. @@ -806,23 +865,23 @@ subroutine sw_initialize_deformation_weights( grid ) if (debug) write(0,*) ' beginning cell loop ' - do iCell = 1, grid % nCells + do iCell = 1, nCells if (debug) write(0,*) ' cell loop ', iCell cell_list(1) = iCell - do i=2, grid % nEdgesOnCell % array(iCell)+1 - cell_list(i) = grid % CellsOnCell % array(i-1,iCell) + do i = 2, nEdgesOnCell(iCell)+1 + cell_list(i) = CellsOnCell(i-1,iCell) end do - n = grid % nEdgesOnCell % array(iCell) + 1 + n = nEdgesOnCell(iCell) + 1 ! check to see if we are reaching outside the halo if (debug) write(0,*) ' points ', n do_the_cell = .true. - do i=1,n - if (cell_list(i) > grid % nCells) do_the_cell = .false. + do i = 1, n + if (cell_list(i) > nCells) do_the_cell = .false. end do @@ -830,27 +889,27 @@ subroutine sw_initialize_deformation_weights( grid ) ! compute poynomial fit for this cell if all needed neighbors exist - if (grid % on_a_sphere) then + if (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) = xCell(iCell) / sphere_radius + yc(1) = yCell(iCell) / sphere_radius + zc(1) = zCell(iCell) / 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 + do i = 2, n + iv = verticesOnCell(i-1,iCell) + xc(i) = xVertex(iv) / sphere_radius + yc(i) = yVertex(iv) / sphere_radius + zc(i) = zVertex(iv) / sphere_radius end do - theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), & + theta_abs(iCell) = pii / 2. - sphere_angle( xc(1), yc(1), zc(1), & xc(2), yc(2), zc(2), & 0.0_RKIND, 0.0_RKIND, 1.0_RKIND ) ! angles from cell center to neighbor centers (thetav) - do i=1,n-1 + do i = 1, n-1 ip2 = i+2 if (ip2 > n) ip2 = 2 @@ -864,38 +923,38 @@ subroutine sw_initialize_deformation_weights( grid ) end do length_scale = 1. - do i=1,n-1 - dl_sphere(i) = dl_sphere(i)/length_scale + do i = 1, n-1 + dl_sphere(i) = dl_sphere(i) / length_scale end do thetat(1) = 0. ! this defines the x direction, cell center 1 -> ! thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line - do i=2,n-1 + do i = 2, n-1 thetat(i) = thetat(i-1) + thetav(i-1) end do - do i=1,n-1 + do i = 1, n-1 xp(i) = cos(thetat(i)) * dl_sphere(i) yp(i) = sin(thetat(i)) * dl_sphere(i) end do else ! On an x-y plane - xp(1) = grid % xCell % array(iCell) - yp(1) = grid % yCell % array(iCell) + xp(1) = xCell(iCell) + yp(1) = yCell(iCell) - do i=2,n - iv = grid % verticesOnCell % array(i-1,iCell) - xp(i) = grid % xVertex % array(iv) - yp(i) = grid % yVertex % array(iv) + do i = 2, n + iv = verticesOnCell(i-1,iCell) + xp(i) = xVertex(iv) + yp(i) = yVertex(iv) end do end if ! thetat(1) = 0. thetat(1) = theta_abs(iCell) - do i=2,n-1 + do i = 2, n-1 ip1 = i+1 if (ip1 == n) ip1 = 1 thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & @@ -907,7 +966,7 @@ subroutine sw_initialize_deformation_weights( grid ) area_cell = 0. area_cellt = 0. - do i=1,n-1 + do i = 1, n-1 ip1 = i+1 if (ip1 == n) ip1 = 1 dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) @@ -916,7 +975,7 @@ subroutine sw_initialize_deformation_weights( grid ) end do if (debug) write(0,*) ' area_cell, area_cellt ',area_cell, area_cellt,area_cell-area_cellt - do i=1,n-1 + do i = 1, n-1 ip1 = i+1 if (ip1 == n) ip1 = 1 dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) @@ -925,7 +984,7 @@ subroutine sw_initialize_deformation_weights( grid ) sint_cost = sin(thetat(i))*cos(thetat(i)) defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell defc_b(i,iCell) = dl*2.*sint_cost/area_cell - if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then + if (cellsOnEdge(1,edgesOnCell(i,iCell)) /= iCell) then defc_a(i,iCell) = - defc_a(i,iCell) defc_b(i,iCell) = - defc_b(i,iCell) end if diff --git a/src/core_sw/mpas_sw_constants.F b/src/core_sw/mpas_sw_constants.F new file mode 100644 index 0000000000..2dc5e15008 --- /dev/null +++ b/src/core_sw/mpas_sw_constants.F @@ -0,0 +1,33 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +module sw_constants + + use mpas_grid_types + use mpas_constants + + public + save + + type (mpas_pool_type), pointer :: swConfigs, swPackages + + + contains + + + subroutine sw_constants_init(configPool, packagePool) + type (mpas_pool_type), pointer :: configPool + type (mpas_pool_type), pointer :: packagePool + + swConfigs => configPool + swPackages => swPackages + + end subroutine sw_constants_init + + + +end module sw_constants diff --git a/src/core_sw/mpas_sw_global_diagnostics.F b/src/core_sw/mpas_sw_global_diagnostics.F index f0dc1c4fc3..09da795381 100644 --- a/src/core_sw/mpas_sw_global_diagnostics.F +++ b/src/core_sw/mpas_sw_global_diagnostics.F @@ -12,13 +12,15 @@ module sw_global_diagnostics use mpas_constants use mpas_dmpar + use sw_constants + implicit none save public contains - subroutine sw_compute_global_diagnostics(dminfo, state, grid, timeIndex, dt) + subroutine sw_compute_global_diagnostics(dminfo, statePool, meshPool, timeIndex, dt, timeLevelIn) ! Note: this routine assumes that there is only one block per processor. No looping ! is preformed over blocks. @@ -44,13 +46,14 @@ subroutine sw_compute_global_diagnostics(dminfo, state, grid, timeIndex, dt) implicit none type (dm_info), intent(in) :: dminfo - type (state_type), intent(inout) :: state - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(inout) :: statePool + type (mpas_pool_type), intent(in) :: meshPool integer, intent(in) :: timeIndex real (kind=RKIND), intent(in) :: dt + integer, intent(in), optional :: timeLevelIn - integer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer - integer :: nCells + integer :: nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer + integer, pointer :: nCells, nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve ! Step 1 ! 1. Define the array to integrate, and the variable for the value to be stored in after the integration @@ -80,42 +83,50 @@ subroutine sw_compute_global_diagnostics(dminfo, state, grid, timeIndex, dt) integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins integer :: timeLevel, eoe, iLevel, iCell, iEdge, iVertex integer :: fileID, iCell1, iCell2, j + integer, pointer :: config_stats_interval integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, edgesOnEdge integer, dimension(:), pointer :: nEdgesOnEdge + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + endif + + call mpas_pool_get_config(swConfigs, 'config_stats_interval', config_stats_interval) - cellsOnEdge => grid % cellsOnEdge % array - edgesOnCell => grid % edgesOnCell % array - - nVertLevels = grid % nVertLevels - nCellsSolve = grid % nCellsSolve - nEdgesSolve = grid % nEdgesSolve - nVerticesSolve = grid % nVerticesSolve - nCells = grid % nCells - - h_s => grid % h_s % array - areaCell => grid % areaCell % array - dcEdge => grid % dcEdge % array - dvEdge => grid % dvEdge % array - areaTriangle => grid % areaTriangle % array - fCell => grid % fCell % array - fEdge => grid % fEdge % array - edgesOnEdge => grid % edgesOnEdge % array - nEdgesOnEdge => grid % nEdgesOnEdge % array + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'h_s', h_s) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'fCell', fCell) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(meshPool, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(meshPool, 'weightsOnEdge', weightsOnEdge) allocate(areaEdge(1:nEdgesSolve)) areaEdge = dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve) - weightsOnEdge => grid % weightsOnEdge % array - - h => state % h % array - u => state % u % array - v => state % v % array - tracers => state % tracers % array - h_edge => state % h_edge % array - h_vertex => state % h_vertex % array - pv_edge => state % pv_edge % array - pv_vertex => state % pv_vertex % array - pv_cell => state % pv_cell % array + + call mpas_pool_get_array(statePool, 'h', h, timeLevel) + call mpas_pool_get_array(statePool, 'u', u, timeLevel) + call mpas_pool_get_array(statePool, 'v', v, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(statePool, 'h_edge', h_edge, timeLevel) + call mpas_pool_get_array(statePool, 'h_vertex', h_vertex, timeLevel) + call mpas_pool_get_array(statePool, 'pv_edge', pv_edge, timeLevel) + call mpas_pool_get_array(statePool, 'pv_vertex', pv_vertex, timeLevel) + call mpas_pool_get_array(statePool, 'pv_cell', pv_cell, timeLevel) ! Step 2 ! 2. Allocate the array with the correct dimensions. @@ -242,7 +253,7 @@ subroutine sw_compute_global_diagnostics(dminfo, state, grid, timeIndex, dt) globalPotentialEnstrophy = globalPotentialEnstrophy/sumVertexVolume ! Compte Potential Enstrophy Reservior - potentialEnstrophyReservior(:) = areaCell(:)*fCell(:)*fCell(:)/averageThickness + potentialEnstrophyReservior(:) = areaCell(1:nCellsSolve)*fCell(1:nCellsSolve)*fCell(1:nCellsSolve)/averageThickness call sw_compute_global_sum(dminfo, 1, nCellsSolve, potentialEnstrophyReservior, globalPotentialEnstrophyReservoir) globalPotentialEnstrophyReservoir = globalPotentialEnstrophyReservoir/sumCellVolume diff --git a/src/core_sw/mpas_sw_mpas_core.F b/src/core_sw/mpas_sw_mpas_core.F index d4f19f3712..3b5b2f3daf 100644 --- a/src/core_sw/mpas_sw_mpas_core.F +++ b/src/core_sw/mpas_sw_mpas_core.F @@ -10,31 +10,70 @@ module mpas_core use mpas_framework use mpas_timekeeping - type (io_output_object), save :: restart_obj - integer :: current_outfile_frames - - type (MPAS_Clock_type) :: clock - - integer, parameter :: outputAlarmID = 1 - integer, parameter :: restartAlarmID = 2 - !integer, parameter :: statsAlarmID = 3 + type (MPAS_Clock_type), pointer :: clock contains - subroutine mpas_core_init(domain, startTimeStamp) + + subroutine mpas_core_init(domain, stream_manager, startTimeStamp) use mpas_configure use mpas_grid_types + use mpas_stream_manager use sw_test_cases + use sw_constants implicit none type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager character(len=*), intent(out) :: startTimeStamp real (kind=RKIND) :: dt type (block_type), pointer :: block + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool + + logical, pointer :: config_do_restart + real (kind=RKIND), pointer :: config_dt + character (len=StrKIND), pointer :: xtime + type (MPAS_Time_Type) :: startTime + integer :: ierr + + call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(domain % configs, 'config_dt', config_dt) + + + ! + ! Set "local" clock to point to the clock contained in the domain type + ! + clock => domain % clock + + + ! + ! Set startTimeStamp based on the start time of the simulation clock + ! + startTime = mpas_get_clock_time(clock, MPAS_START_TIME, ierr) + call mpas_get_time(startTime, dateTimeString=startTimeStamp) + + ! + ! If this is a restart run, read the restart stream, else read the input stream. + ! Regardless of which stream we read for initial conditions, reset the + ! input alarms for both input and restart before reading any remaining input streams. + ! + if (config_do_restart) then + call MPAS_stream_mgr_read(stream_manager, streamID='restart', ierr=ierr) + else + call MPAS_stream_mgr_read(stream_manager, streamID='input', ierr=ierr) + end if + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='input', direction=MPAS_STREAM_INPUT, ierr=ierr) + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='restart', direction=MPAS_STREAM_INPUT, ierr=ierr) + ! Read all other inputs + call MPAS_stream_mgr_read(stream_manager, ierr=ierr) + call MPAS_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_INPUT, ierr=ierr) + + call sw_constants_init(domain % configs, domain % packages) if (.not. config_do_restart) call setup_sw_test_case(domain) @@ -43,80 +82,81 @@ subroutine mpas_core_init(domain, startTimeStamp) ! dt = config_dt - call simulation_clock_init(domain, dt, startTimeStamp) - block => domain % blocklist do while (associated(block)) - call mpas_init_block(block, block % mesh, dt) - block % state % time_levs(1) % state % xtime % scalar = startTimeStamp + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + call mpas_init_block(block, meshPool, dt) + + call mpas_pool_get_array(statePool, 'xtime', xtime, 1) + + xtime = startTimeStamp block => block % next end do - current_outfile_frames = 0 - end subroutine mpas_core_init - subroutine simulation_clock_init(domain, dt, startTimeStamp) + subroutine simulation_clock_init(core_clock, configs, ierr) implicit none - type (domain_type), intent(inout) :: domain - real (kind=RKIND), intent(in) :: dt - character(len=*), intent(out) :: startTimeStamp + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep - integer :: ierr + integer :: local_err - call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr) - call mpas_set_timeInterval(timeStep, dt=dt, ierr=ierr) + character (len=StrKIND), pointer :: config_start_time, config_run_duration, config_stop_time, config_output_interval, config_restart_interval + real (kind=RKIND), pointer :: config_dt + + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_dt', config_dt) + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_run_duration', config_run_duration) + call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) + call mpas_pool_get_config(configs, 'config_output_interval', config_output_interval) + call mpas_pool_get_config(configs, 'config_restart_interval', config_restart_interval) + + call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=local_err) + call mpas_set_timeInterval(timeStep, dt=config_dt, ierr=local_err) 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) + call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=local_err) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=local_err) if (trim(config_stop_time) /= "none") then - call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr) + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=local_err) if(startTime + runduration /= stopTime) then write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.' end if end if else if (trim(config_stop_time) /= "none") then - call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr) - call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr) + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=local_err) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=local_err) else write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' - call mpas_dmpar_abort(domain % dminfo) - end if - - ! set output alarm - call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) - - ! set restart alarm, if necessary - if (trim(config_restart_interval) /= "none") then - call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr) - alarmStartTime = startTime + alarmTimeStep - call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) + ierr = 1 end if !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) + ! call mpas_set_timeInterval(alarmTimeStep, timeString=config_stats_interval, ierr=local_err) ! alarmStartTime = startTime + alarmTimeStep - ! call mpas_add_clock_alarm(clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr) + ! call mpas_add_clock_alarm(core_clock, statsAlarmID, alarmStartTime, alarmTimeStep, ierr=local_err) !end if - call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr) - end subroutine simulation_clock_init - subroutine mpas_init_block(block, mesh, dt) + subroutine mpas_init_block(block, meshPool, dt) use mpas_grid_types use sw_time_integration @@ -126,47 +166,60 @@ subroutine mpas_init_block(block, mesh, dt) implicit none type (block_type), intent(inout) :: block - type (mesh_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: meshPool real (kind=RKIND), intent(in) :: dt + + type (mpas_pool_type), pointer :: statePool + + real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional + call mpas_pool_get_subpool(block % structs, 'state', statePool) + - call sw_compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh) - call compute_mesh_scaling(mesh) + call mpas_pool_get_array(statePool, 'u', u, 1) + call mpas_pool_get_array(statePool, 'uReconstructX', uReconstructX, 1) + call mpas_pool_get_array(statePool, 'uReconstructY', uReconstructY, 1) + call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, 1) + call mpas_pool_get_array(statePool, 'uReconstructZonal', uReconstructZonal, 1) + call mpas_pool_get_array(statePool, 'uReconstructMeridional', uReconstructMeridional, 1) - call mpas_rbf_interp_initialize(mesh) - call mpas_init_reconstruct(mesh) - call mpas_reconstruct(mesh, block % state % time_levs(1) % state % u % array, & - block % state % time_levs(1) % state % uReconstructX % array, & - block % state % time_levs(1) % state % uReconstructY % array, & - block % state % time_levs(1) % state % uReconstructZ % array, & - block % state % time_levs(1) % state % uReconstructZonal % array, & - block % state % time_levs(1) % state % uReconstructMeridional % array & - ) + call sw_compute_solve_diagnostics(dt, statePool, meshPool, 1) + call compute_mesh_scaling(meshPool) + + call mpas_rbf_interp_initialize(meshPool) + call mpas_init_reconstruct(meshPool) + call mpas_reconstruct(meshPool, u, & + uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional) end subroutine mpas_init_block - subroutine mpas_core_run(domain, output_obj, output_frame) + subroutine mpas_core_run(domain, stream_manager) use mpas_grid_types use mpas_kind_types - use mpas_io_output + use mpas_stream_manager use mpas_timer implicit none type (domain_type), intent(inout) :: domain - type (io_output_object), intent(inout) :: output_obj - integer, intent(inout) :: output_frame + type (MPAS_streamManager_type), intent(inout) :: stream_manager integer :: itimestep real (kind=RKIND) :: dt type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: statePool type (MPAS_Time_Type) :: currTime character(len=StrKIND) :: timeStamp integer :: ierr + + real (kind=RKIND), pointer :: config_dt + + call mpas_pool_get_config(domain % configs, 'config_dt', config_dt) ! Eventually, dt should be domain specific dt = config_dt @@ -175,7 +228,11 @@ subroutine mpas_core_run(domain, output_obj, output_frame) call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) write(0,*) 'Initial timestep ', trim(timeStamp) - call write_output_frame(output_obj, output_frame, domain) + ! Avoid writing a restart file at the initial time + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + + call mpas_stream_mgr_write(stream_manager, ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) @@ -196,101 +253,19 @@ subroutine mpas_core_run(domain, output_obj, output_frame) ! Move time level 2 fields back into time level 1 for next time step block_ptr => domain % blocklist do while(associated(block_ptr)) - call mpas_shift_time_levels_state(block_ptr % state) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_shift_time_levels(statePool) block_ptr => block_ptr % next end do - !TODO: mpas_get_clock_ringing_alarms is probably faster than multiple mpas_is_alarm_ringing... - - 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 - 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)) - end if - call write_output_frame(output_obj, output_frame, domain) - end if - - if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then - call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr) - - ! Write one restart time per file - call mpas_output_state_init(restart_obj, domain, "RESTART", trim(timeStamp)) - call mpas_output_state_for_domain(restart_obj, domain, 1) - call mpas_output_state_finalize(restart_obj, domain % dminfo) - end if + call mpas_stream_mgr_write(stream_manager, ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) end do end subroutine mpas_core_run - subroutine write_output_frame(output_obj, output_frame, domain) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Compute diagnostic fields for a domain and write model state to output file - ! - ! Input/Output: domain - contains model state; diagnostic field are computed - ! before returning - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_grid_types - use mpas_io_output - - implicit none - - type (io_output_object), intent(inout) :: output_obj - integer, intent(inout) :: output_frame - type (domain_type), intent(inout) :: domain - - integer :: i, j, k - integer :: eoe - type (block_type), pointer :: block_ptr - - block_ptr => domain % blocklist - do while (associated(block_ptr)) - call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh) - block_ptr => block_ptr % next - end do - - call mpas_output_state_for_domain(output_obj, domain, output_frame) - output_frame = output_frame + 1 - - ! reset frame if the maximum number of frames per outfile has been reached - if (config_frames_per_outfile > 0) then - current_outfile_frames = current_outfile_frames + 1 - if(current_outfile_frames >= config_frames_per_outfile) then - current_outfile_frames = 0 - output_frame = 1 - end if - end if - - end subroutine write_output_frame - - - subroutine compute_output_diagnostics(state, grid) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Compute diagnostic fields for a domain - ! - ! Input: state - contains model prognostic fields - ! grid - contains grid metadata - ! - ! Output: state - upon returning, diagnostic fields will have be computed - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_grid_types - - implicit none - - type (state_type), intent(inout) :: state - type (mesh_type), intent(in) :: grid - - integer :: i, eoe - integer :: iEdge, k - - end subroutine compute_output_diagnostics - - subroutine mpas_timestep(domain, itimestep, dt, timeStamp) use mpas_grid_types @@ -306,7 +281,11 @@ subroutine mpas_timestep(domain, itimestep, dt, timeStamp) character(len=*), intent(in) :: timeStamp type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: statePool, meshPool integer :: ierr + integer, pointer :: config_stats_interval + + call mpas_pool_get_config(domain % configs, 'config_stats_interval', config_stats_interval) call sw_timestep(domain, dt, timeStamp) @@ -317,11 +296,13 @@ subroutine mpas_timestep(domain, itimestep, dt, timeStamp) write(0,*) 'Error: computeGlobalDiagnostics assumes ',& 'that there is only one block per processor.' end if + + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) call mpas_timer_start("global_diagnostics") call sw_compute_global_diagnostics(domain % dminfo, & - block_ptr % state % time_levs(2) % state, block_ptr % mesh, & - itimestep, dt) + statePool, meshPool, itimestep, dt, 2) call mpas_timer_stop("global_diagnostics") end if end if @@ -346,13 +327,15 @@ subroutine mpas_timestep(domain, itimestep, dt, timeStamp) end subroutine mpas_timestep - subroutine mpas_core_finalize(domain) + subroutine mpas_core_finalize(domain, stream_manager) use mpas_grid_types + use mpas_stream_manager implicit none type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager integer :: ierr call mpas_destroy_clock(clock, ierr) @@ -360,20 +343,30 @@ subroutine mpas_core_finalize(domain) end subroutine mpas_core_finalize - subroutine compute_mesh_scaling(mesh) + subroutine compute_mesh_scaling(meshPool) use mpas_grid_types + use sw_constants implicit none - type (mesh_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: meshPool integer :: iEdge, cell1, cell2 + integer, pointer :: nEdges + integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:), pointer :: meshDensity, meshScalingDel2, meshScalingDel4 - meshDensity => mesh % meshDensity % array - meshScalingDel2 => mesh % meshScalingDel2 % array - meshScalingDel4 => mesh % meshScalingDel4 % array + logical, pointer :: config_h_ScaleWithMesh + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'meshDensity', meshDensity) + call mpas_pool_get_array(meshPool, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(meshPool, 'meshScalingDel4', meshScalingDel4) + + call mpas_pool_get_config(swConfigs, 'config_h_ScaleWithMesh', config_h_ScaleWithMesh) ! ! Compute the scaling factors to be used in the del2 and del4 dissipation @@ -381,9 +374,9 @@ subroutine compute_mesh_scaling(mesh) meshScalingDel2(:) = 1.0 meshScalingDel4(:) = 1.0 if (config_h_ScaleWithMesh) then - do iEdge=1,mesh%nEdges - cell1 = mesh % cellsOnEdge % array(1,iEdge) - cell2 = mesh % cellsOnEdge % array(2,iEdge) + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) meshScalingDel2(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**(5.0/12.0) meshScalingDel4(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**(5.0/6.0) end do @@ -391,30 +384,99 @@ subroutine compute_mesh_scaling(mesh) end subroutine compute_mesh_scaling -!*********************************************************************** -! -! routine mpas_core_setup_packages -! -!> \brief Pacakge setup routine -!> \author Doug Jacobsen -!> \date September 2011 -!> \details -!> This routine is intended to correctly configure the packages for this MPAS -!> core. It can use any Fortran logic to properly configure packages, and it -!> can also make use of any namelist options. All variables in the model are -!> *not* allocated until after this routine is called. -! -!----------------------------------------------------------------------- - subroutine mpas_core_setup_packages(ierr)!{{{ - - use mpas_packages + !*********************************************************************** + ! + ! routine mpas_core_setup_packages + ! + !> \brief Pacakge setup routine + !> \author Doug Jacobsen + !> \date September 2011 + !> \details + !> This routine is intended to correctly configure the packages for this MPAS + !> core. It can use any Fortran logic to properly configure packages, and it + !> can also make use of any namelist options. All variables in the model are + !> *not* allocated until after this routine is called. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_setup_packages(configPool, packagePool, ierr)!{{{ implicit none + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool integer, intent(out) :: ierr ierr = 0 end subroutine mpas_core_setup_packages!}}} + + !*********************************************************************** + ! + ! routine mpas_core_setup_clock + ! + !> \brief Pacakge setup routine + !> \author Michael Duda + !> \date 6 August 2014 + !> \details + !> The purpose of this routine is to allow the core to set up a simulation + !> clock that will be used by the I/O subsystem for timing reads and writes + !> of I/O streams. + !> This routine is called from the superstructure after the framework + !> has been initialized but before any fields have been allocated and + !> initial fields have been read from input files. However, all namelist + !> options are available. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_setup_clock(core_clock, configs, ierr) + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + call simulation_clock_init(core_clock, configs, ierr) + + end subroutine mpas_core_setup_clock + + + !*********************************************************************** + ! + ! routine mpas_core_get_mesh_stream + ! + !> \brief Returns the name of the stream containing mesh information + !> \author Michael Duda + !> \date 8 August 2014 + !> \details + !> This routine returns the name of the I/O stream containing dimensions, + !> attributes, and mesh fields needed by the framework bootstrapping + !> routine. At the time this routine is called, only namelist options + !> are available. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_get_mesh_stream(configs, stream, ierr) + + implicit none + + type (mpas_pool_type), intent(in) :: configs + character(len=*), intent(out) :: stream + integer, intent(out) :: ierr + + logical, pointer :: config_do_restart + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) + + if (.not. associated(config_do_restart)) then + ierr = 1 + else if (config_do_restart) then + write(stream,'(a)') 'restart' + else + write(stream,'(a)') 'input' + end if + + end subroutine mpas_core_get_mesh_stream + end module mpas_core diff --git a/src/core_sw/mpas_sw_test_cases.F b/src/core_sw/mpas_sw_test_cases.F index e5a1a49175..0a5a9214a3 100644 --- a/src/core_sw/mpas_sw_test_cases.F +++ b/src/core_sw/mpas_sw_test_cases.F @@ -31,6 +31,12 @@ subroutine setup_sw_test_case(domain) integer :: i type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: statePool, meshPool + + integer, pointer :: config_test_case + + call mpas_pool_get_config(domain % configs, 'config_test_case', config_test_case) + if (config_test_case == 0) then write(0,*) 'Using initial conditions supplied in input file' @@ -40,10 +46,12 @@ subroutine setup_sw_test_case(domain) block_ptr => domain % blocklist do while (associated(block_ptr)) - call sw_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state) - do i=2,nTimeLevs - call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state) - end do + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + + call sw_test_case_1(meshPool, statePool) + + call mpas_pool_initialize_time_levels(statePool) block_ptr => block_ptr % next end do @@ -54,10 +62,12 @@ subroutine setup_sw_test_case(domain) block_ptr => domain % blocklist do while (associated(block_ptr)) - call sw_test_case_2(block_ptr % mesh, block_ptr % state % time_levs(1) % state) - do i=2,nTimeLevs - call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state) - end do + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + + call sw_test_case_2(meshPool, statePool) + + call mpas_pool_initialize_time_levels(statePool) block_ptr => block_ptr % next end do @@ -68,10 +78,12 @@ subroutine setup_sw_test_case(domain) block_ptr => domain % blocklist do while (associated(block_ptr)) - call sw_test_case_5(block_ptr % mesh, block_ptr % state % time_levs(1) % state) - do i=2,nTimeLevs - call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state) - end do + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + + call sw_test_case_5(meshPool, statePool) + + call mpas_pool_initialize_time_levels(statePool) block_ptr => block_ptr % next end do @@ -82,10 +94,12 @@ subroutine setup_sw_test_case(domain) block_ptr => domain % blocklist do while (associated(block_ptr)) - call sw_test_case_6(block_ptr % mesh, block_ptr % state % time_levs(1) % state) - do i=2,nTimeLevs - call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state) - end do + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + + call sw_test_case_6(meshPool, statePool) + + call mpas_pool_initialize_time_levels(statePool) block_ptr => block_ptr % next end do @@ -98,7 +112,7 @@ subroutine setup_sw_test_case(domain) end subroutine setup_sw_test_case - subroutine sw_test_case_1(grid, state) + subroutine sw_test_case_1(meshPool, statePool) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup shallow water test case 1: Advection of Cosine Bell over the Pole ! @@ -109,8 +123,8 @@ subroutine sw_test_case_1(grid, state) implicit none - type (mesh_type), intent(inout) :: grid - type (state_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: meshPool + type (mpas_pool_type), intent(inout) :: statePool real (kind=RKIND), parameter :: u0 = 2.0 * pii * a / (12.0 * 86400.0) real (kind=RKIND), parameter :: h0 = 1000.0 @@ -119,61 +133,100 @@ subroutine sw_test_case_1(grid, state) real (kind=RKIND), parameter :: alpha = pii/4.0 integer :: iCell, iEdge, iVtx - real (kind=RKIND) :: r, u, v + integer, pointer :: nVertices, nEdges, nCells + real (kind=RKIND) :: r, v real (kind=RKIND), allocatable, dimension(:) :: psiVertex + integer, dimension(:,:), pointer :: verticesOnEdge + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, xEdge, yEdge, zEdge, dvEdge, dcEdge + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latVertex, lonVertex + real (kind=RKIND), dimension(:), pointer :: areaCell, areaTriangle + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + + real (kind=RKIND), dimension(:,:), pointer :: u, h + ! ! 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 + + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(meshPool, 'xEdge', xEdge) + call mpas_pool_get_array(meshPool, 'yEdge', yEdge) + call mpas_pool_get_array(meshPool, 'zEdge', zEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'latVertex', latVertex) + call mpas_pool_get_array(meshPool, 'lonVertex', lonVertex) + + call mpas_pool_get_array(statePool, 'u', u, 1) + call mpas_pool_get_array(statePool, 'h', h, 1) + + xCell = xCell * a + yCell = yCell * a + zCell = zCell * a + xVertex = xVertex * a + yVertex = yVertex * a + zVertex = zVertex * a + xEdge = xEdge * a + yEdge = yEdge * a + zEdge = zEdge * a + dvEdge = dvEdge * a + dcEdge = dcEdge * a + areaCell = areaCell * a**2.0 + areaTriangle = areaTriangle * a**2.0 + kiteAreasOnVertex = kiteAreasOnVertex * a**2.0 ! ! Initialize wind field ! - allocate(psiVertex(grid % nVertices)) - do iVtx=1,grid % nVertices + allocate(psiVertex(nVertices)) + do iVtx = 1, nVertices psiVertex(iVtx) = -a * u0 * ( & - sin(grid%latVertex%array(iVtx)) * cos(alpha) - & - cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) & + sin(latVertex(iVtx)) * cos(alpha) - & + cos(lonVertex(iVtx)) * cos(latVertex(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) + do iEdge = 1, nEdges + u(1,iEdge) = -1.0 * ( & + psiVertex(verticesOnEdge(2,iEdge)) - & + psiVertex(verticesOnEdge(1,iEdge)) & + ) / dvEdge(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) + do iCell = 1, nCells + r = sphere_distance(theta_c, lambda_c, latCell(iCell), lonCell(iCell), a) if (r < a/3.0) then - state % h % array(1,iCell) = (h0 / 2.0) * (1.0 + cos(pii*r*3.0/a)) + h(1,iCell) = (h0 / 2.0) * (1.0 + cos(pii*r*3.0/a)) else - state % h % array(1,iCell) = 0.0 + h(1,iCell) = h0 / 2.0 end if end do end subroutine sw_test_case_1 - subroutine sw_test_case_2(grid, state) + subroutine sw_test_case_2(meshPool, statePool) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup shallow water test case 2: Global Steady State Nonlinear Zonal ! Geostrophic Flow @@ -185,78 +238,122 @@ subroutine sw_test_case_2(grid, state) implicit none - type (mesh_type), intent(inout) :: grid - type (state_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: meshPool + type (mpas_pool_type), intent(inout) :: statePool 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 + integer, pointer :: nVertices, nEdges, nCells + real (kind=RKIND) :: v real (kind=RKIND), allocatable, dimension(:) :: psiVertex + integer, dimension(:,:), pointer :: verticesOnEdge + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, xEdge, yEdge, zEdge, dvEdge, dcEdge + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latVertex, lonVertex + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: areaCell, areaTriangle, fEdge, fVertex + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + + real (kind=RKIND), dimension(:,:), pointer :: u, h + ! ! 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 + + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(meshPool, 'xEdge', xEdge) + call mpas_pool_get_array(meshPool, 'yEdge', yEdge) + call mpas_pool_get_array(meshPool, 'zEdge', zEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'latVertex', latVertex) + call mpas_pool_get_array(meshPool, 'lonVertex', lonVertex) + call mpas_pool_get_array(meshPool, 'latEdge', latEdge) + call mpas_pool_get_array(meshPool, 'lonEdge', lonEdge) + + call mpas_pool_get_array(statePool, 'u', u, 1) + call mpas_pool_get_array(statePool, 'h', h, 1) + + xCell = xCell * a + yCell = yCell * a + zCell = zCell * a + xVertex = xVertex * a + yVertex = yVertex * a + zVertex = zVertex * a + xEdge = xEdge * a + yEdge = yEdge * a + zEdge = zEdge * a + dvEdge = dvEdge * a + dcEdge = dcEdge * a + areaCell = areaCell * a**2.0 + areaTriangle = areaTriangle * a**2.0 + kiteAreasOnVertex = kiteAreasOnVertex * a**2.0 ! ! Initialize wind field ! - allocate(psiVertex(grid % nVertices)) - do iVtx=1,grid % nVertices + allocate(psiVertex(nVertices)) + do iVtx = 1, nVertices psiVertex(iVtx) = -a * u0 * ( & - sin(grid%latVertex%array(iVtx)) * cos(alpha) - & - cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) & - ) + sin(latVertex(iVtx)) * cos(alpha) - & + cos(lonVertex(iVtx)) * cos(latVertex(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) + do iEdge = 1,nEdges + u(1,iEdge) = -1.0 * ( & + psiVertex(verticesOnEdge(2,iEdge)) - & + psiVertex(verticesOnEdge(1,iEdge)) & + ) / dvEdge(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) & - ) + do iEdge = 1, nEdges + fEdge(iEdge) = 2.0 * omega * & + ( -cos(lonEdge(iEdge)) * cos(latEdge(iEdge)) * sin(alpha) + & + sin(latEdge(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) & + do iVtx = 1, nVertices + fVertex(iVtx) = 2.0 * omega * & + (-cos(lonVertex(iVtx)) * cos(latVertex(iVtx)) * sin(alpha) + & + sin(latVertex(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) & + do iCell = 1, nCells + h(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * & + (-cos(lonCell(iCell)) * cos(latCell(iCell)) * sin(alpha) + & + sin(latCell(iCell)) * cos(alpha) & )**2.0 & ) / & gravity @@ -265,7 +362,7 @@ subroutine sw_test_case_2(grid, state) end subroutine sw_test_case_2 - subroutine sw_test_case_5(grid, state) + subroutine sw_test_case_5(meshPool, statePool) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup shallow water test case 5: Zonal Flow over an Isolated Mountain ! @@ -276,8 +373,8 @@ subroutine sw_test_case_5(grid, state) implicit none - type (mesh_type), intent(inout) :: grid - type (state_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: meshPool + type (mpas_pool_type), intent(inout) :: statePool real (kind=RKIND), parameter :: u0 = 20. real (kind=RKIND), parameter :: gh0 = 5960.0*gravity @@ -287,106 +384,153 @@ subroutine sw_test_case_5(grid, state) 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 + integer :: iCell, iEdge, iVtx, nTracers + integer, pointer :: nVertices, nEdges, nCells + real (kind=RKIND) :: r, v real (kind=RKIND), allocatable, dimension(:) :: psiVertex + integer, dimension(:,:), pointer :: verticesOnEdge + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, xEdge, yEdge, zEdge, dvEdge, dcEdge + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latVertex, lonVertex + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: areaCell, areaTriangle, h_s, fEdge, fVertex + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + + real (kind=RKIND), dimension(:,:), pointer :: u, h + real (kind=RKIND), dimension(:,:,:), pointer :: tracers ! ! 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 + + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(meshPool, 'xEdge', xEdge) + call mpas_pool_get_array(meshPool, 'yEdge', yEdge) + call mpas_pool_get_array(meshPool, 'zEdge', zEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'latVertex', latVertex) + call mpas_pool_get_array(meshPool, 'lonVertex', lonVertex) + call mpas_pool_get_array(meshPool, 'latEdge', latEdge) + call mpas_pool_get_array(meshPool, 'lonEdge', lonEdge) + call mpas_pool_get_array(meshPool, 'h_s', h_s) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + + call mpas_pool_get_array(statePool, 'u', u, 1) + call mpas_pool_get_array(statePool, 'h', h, 1) + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + nTracers = size(tracers, dim=1) + + xCell = xCell * a + yCell = yCell * a + zCell = zCell * a + xVertex = xVertex * a + yVertex = yVertex * a + zVertex = zVertex * a + xEdge = xEdge * a + yEdge = yEdge * a + zEdge = zEdge * a + dvEdge = dvEdge * a + dcEdge = dcEdge * a + areaCell = areaCell * a**2.0 + areaTriangle = areaTriangle * a**2.0 + kiteAreasOnVertex = kiteAreasOnVertex * a**2.0 ! ! Initialize wind field ! - allocate(psiVertex(grid % nVertices)) - do iVtx=1,grid % nVertices + allocate(psiVertex(nVertices)) + do iVtx = 1, nVertices psiVertex(iVtx) = -a * u0 * ( & - sin(grid%latVertex%array(iVtx)) * cos(alpha) - & - cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha) & + sin(latVertex(iVtx)) * cos(alpha) - & + cos(lonVertex(iVtx)) * cos(latVertex(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) + do iEdge = 1, nEdges + u(1,iEdge) = -1.0 * ( & + psiVertex(verticesOnEdge(2,iEdge)) - & + psiVertex(verticesOnEdge(1,iEdge)) & + ) / dvEdge(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) & + do iEdge = 1, nEdges + fEdge(iEdge) = 2.0 * omega * & + (-cos(lonEdge(iEdge)) * cos(latEdge(iEdge)) * sin(alpha) + & + sin(latEdge(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) & + do iVtx = 1, nVertices + fVertex(iVtx) = 2.0 * omega * & + (-cos(lonVertex(iVtx)) * cos(latVertex(iVtx)) * sin(alpha) + & + sin(latVertex(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) + do iCell = 1, nCells + if (lonCell(iCell) < 0.0) lonCell(iCell) = lonCell(iCell) + 2.0 * pii + r = sqrt(min(rr**2.0, (lonCell(iCell) - lambda_c)**2.0 + (latCell(iCell) - theta_c)**2.0)) + h_s(iCell) = hs0 * (1.0 - r/rr) end do ! ! 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 + do iCell = 1, nCells + r = sqrt(min(rr**2.0, (lonCell(iCell) - lambda_c)**2.0 + (latCell(iCell) - theta_c)**2.0)) + tracers(1,1,iCell) = 1.0 - r/rr end do - if (grid%nTracers > 1) then - 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 & + if (nTracers > 1) then + do iCell = 1, nCells + r = sqrt(min(rr**2.0, (lonCell(iCell) - lambda_c)**2.0 + & + (latCell(iCell) - theta_c - pii/6.0)**2.0 & ) & ) - state % tracers % array(2,1,iCell) = 1.0 - r/rr + tracers(2,1,iCell) = 1.0 - r/rr end do end if ! ! 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) & + do iCell = 1, nCells + h(1,iCell) = (gh0 - (a * omega * u0 + 0.5 * u0**2.0) * & + (-cos(lonCell(iCell)) * cos(latCell(iCell)) * sin(alpha) + & + sin(latCell(iCell)) * cos(alpha) & )**2.0 & ) / & gravity - state % h % array(1,iCell) = state % h % array(1,iCell) - grid % h_s % array(iCell) + h(1,iCell) = h(1,iCell) - h_s(iCell) end do end subroutine sw_test_case_5 - subroutine sw_test_case_6(grid, state) + subroutine sw_test_case_6(meshPool, statePool) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup shallow water test case 6: Rossby-Haurwitz Wave ! @@ -397,61 +541,106 @@ subroutine sw_test_case_6(grid, state) implicit none - type (mesh_type), intent(inout) :: grid - type (state_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: meshPool + type (mpas_pool_type), intent(inout) :: statePool 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 + integer :: iCell, iEdge, iVtx, nTracers + integer, pointer :: nVertices, nEdges, nCells + real (kind=RKIND) :: v real (kind=RKIND), allocatable, dimension(:) :: psiVertex + integer, dimension(:,:), pointer :: verticesOnEdge + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, xEdge, yEdge, zEdge, dvEdge, dcEdge + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latVertex, lonVertex + real (kind=RKIND), dimension(:), pointer :: areaCell, areaTriangle, h_s + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + + real (kind=RKIND), dimension(:,:), pointer :: u, h + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + ! ! 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 + + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(meshPool, 'xEdge', xEdge) + call mpas_pool_get_array(meshPool, 'yEdge', yEdge) + call mpas_pool_get_array(meshPool, 'zEdge', zEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'latVertex', latVertex) + call mpas_pool_get_array(meshPool, 'lonVertex', lonVertex) + call mpas_pool_get_array(meshPool, 'h_s', h_s) + + call mpas_pool_get_array(statePool, 'u', u, 1) + call mpas_pool_get_array(statePool, 'h', h, 1) + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + nTracers = size(tracers, dim=1) + + + xCell = xCell * a + yCell = yCell * a + zCell = zCell * a + xVertex = xVertex * a + yVertex = yVertex * a + zVertex = zVertex * a + xEdge = xEdge * a + yEdge = yEdge * a + zEdge = zEdge * a + dvEdge = dvEdge * a + dcEdge = dcEdge * a + areaCell = areaCell * a**2.0 + areaTriangle = areaTriangle * a**2.0 + kiteAreasOnVertex = kiteAreasOnVertex * 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)) + allocate(psiVertex(nVertices)) + do iVtx = 1, nVertices + psiVertex(iVtx) = -a * a * w * sin(latVertex(iVtx)) + & + a *a * K * (cos(latVertex(iVtx))**R) * & + sin(latVertex(iVtx)) * cos(R * lonVertex(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) + do iEdge = 1, nEdges + u(1,iEdge) = -1.0 * ( & + psiVertex(verticesOnEdge(2,iEdge)) - & + psiVertex(verticesOnEdge(1,iEdge)) & + ) / dvEdge(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)) & + do iCell = 1, nCells + h(1,iCell) = (gravity * h0 + a*a*aa(latCell(iCell)) + & + a*a*bb(latCell(iCell)) * cos(R*lonCell(iCell)) + & + a*a*cc(latCell(iCell)) * cos(2.0*R*lonCell(iCell)) & ) / gravity end do diff --git a/src/core_sw/mpas_sw_time_integration.F b/src/core_sw/mpas_sw_time_integration.F index 0ab69c3724..65edf71c1e 100644 --- a/src/core_sw/mpas_sw_time_integration.F +++ b/src/core_sw/mpas_sw_time_integration.F @@ -13,6 +13,7 @@ module sw_time_integration use mpas_constants use mpas_dmpar + use sw_constants contains @@ -34,6 +35,12 @@ subroutine sw_timestep(domain, dt, timeStamp) character(len=*), intent(in) :: timeStamp type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + + character (len=StrKIND), pointer :: xtime + character (len=StrKIND), pointer :: config_time_integration + + call mpas_pool_get_config(domain % configs, 'config_time_integration', config_time_integration) if (trim(config_time_integration) == 'RK4') then call sw_rk4(domain, dt) @@ -45,7 +52,10 @@ subroutine sw_timestep(domain, dt, timeStamp) block => domain % blocklist do while (associated(block)) - block % state % time_levs(2) % state % xtime % scalar = timeStamp + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + call mpas_pool_get_array(statePool, 'xtime', xtime, 2) + xtime = timeStamp block => block % next end do @@ -70,15 +80,33 @@ subroutine sw_rk4(domain, dt) integer :: iCell, k type (block_type), pointer :: block - type (state_type), target :: provis_state - type (state_type), pointer :: provis_state_ptr + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: tendPool + type (mpas_pool_type), pointer :: provisStatePool + type (mpas_pool_type), pointer :: prevProvisPool, nextProvisPool integer :: rk_step real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights - call mpas_setup_provis_state(domain % blocklist) - + integer, pointer :: nCells, nEdges, nVertices, nVertLevels + + real (kind=RKIND), dimension(:,:), pointer :: uOld, uNew, uProvis, uTend + real (kind=RKIND), dimension(:,:), pointer :: hOld, hNew, hProvis, hTend + real (kind=RKIND), dimension(:,:), pointer :: uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional + real (kind=RKIND), dimension(:,:,:), pointer :: tracersOld, tracersNew, tracersProvis, tracersTend + + type (field2DReal), pointer :: pvEdgeField, divergenceField, vorticityField, uField, hField + type (field3DReal), pointer :: tracersField + + integer, pointer :: config_test_case + real (kind=RKIND), pointer :: config_h_mom_eddy_visc4 + + + call mpas_pool_get_config(domain % configs, 'config_test_case', config_test_case) + call mpas_pool_get_config(domain % configs, 'config_h_mom_eddy_visc4', config_h_mom_eddy_visc4) + ! ! Initialize time_levs(2) with state at current time ! Initialize first RK state @@ -87,21 +115,70 @@ subroutine sw_rk4(domain, dt) ! block => domain % blocklist do while (associated(block)) - - block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) - block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:) - do iCell=1,block % mesh % nCells ! couple tracers to h - do k=1,block % mesh % nVertLevels - block % state % time_levs(2) % state % tracers % array(:,k,iCell) = block % state % time_levs(1) % state % tracers % array(:,k,iCell) & - * block % state % time_levs(1) % state % h % array(k,iCell) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + allocate(provisStatePool) + call mpas_pool_create_pool(provisStatePool) + call mpas_pool_clone_pool(statePool, provisStatePool, 1) + + call mpas_pool_add_subpool(block % structs, 'provis_state', provisStatePool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(statePool, 'u', uOld, 1) + call mpas_pool_get_array(statePool, 'u', uNew, 2) + call mpas_pool_get_array(statePool, 'h', hOld, 1) + call mpas_pool_get_array(statePool, 'h', hNew, 2) + call mpas_pool_get_array(statePool, 'tracers', tracersOld, 1) + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + + uNew(:,:) = uOld(:,:) + hNew(:,:) = hOld(:,:) + do iCell = 1, nCells ! couple tracers to h + do k = 1, nVertLevels + tracersNew(:,k,iCell) = tracersOld(:,k,iCell) * hOld(k,iCell) end do end do - call mpas_copy_state(block % provis_state, block % state % time_levs(1) % state) + call mpas_pool_initialize_time_levels(statePool) block => block % next end do + block => domain % blocklist + do while(associated(block)) + if (associated(block % prev)) then + call mpas_pool_get_subpool(block % prev % structs, 'provis_state', prevProvisPool) + else + nullify(prevProvisPool) + end if + + if (associated(block % next)) then + call mpas_pool_get_subpool(block % next % structs, 'provis_state', nextProvisPool) + else + nullify(nextProvisPool) + end if + + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + + if (associated(prevProvisPool) .and. associated(nextProvisPool)) then + call mpas_pool_link_pools(provisStatePool, prevProvisPool, nextProvisPool) + else if (associated(prevProvisPool)) then + call mpas_pool_link_pools(provisStatePool, prevProvisPool) + else if (associated(nextProvisPool)) then + call mpas_pool_link_pools(provisStatePool, nextPool=nextProvisPool) + else + call mpas_pool_link_pools(provisStatePool) + end if + + call mpas_pool_link_parinfo(block, provisStatePool) + + block => block % next + end do + + rk_weights(1) = dt/6. rk_weights(2) = dt/3. rk_weights(3) = dt/3. @@ -119,51 +196,83 @@ subroutine sw_rk4(domain, dt) do rk_step = 1, 4 ! --- update halos for diagnostic variables + call mpas_pool_get_subpool(domain % blocklist % structs, 'provis_state', provisStatePool) + + call mpas_pool_get_field(provisStatePool, 'pv_edge', pvEdgeField, 1) - call mpas_dmpar_exch_halo_field(domain % blocklist % provis_state % pv_edge) + call mpas_dmpar_exch_halo_field(pvEdgeField) if (config_h_mom_eddy_visc4 > 0.0) then - call mpas_dmpar_exch_halo_field(domain % blocklist % provis_state % divergence) - call mpas_dmpar_exch_halo_field(domain % blocklist % provis_state % vorticity) - end if + call mpas_pool_get_field(statePool, 'divergence', divergenceField, 2) + call mpas_pool_get_field(statePool, 'vorticity', vorticityField, 2) + call mpas_dmpar_exch_halo_field(divergenceField) + call mpas_dmpar_exch_halo_field(vorticityField) + end if ! --- compute tendencies block => domain % blocklist do while (associated(block)) - call sw_compute_tend(block % tend, block % provis_state, block % mesh) - call sw_compute_scalar_tend(block % tend, block % provis_state, block % mesh) - call sw_enforce_boundary_edge(block % tend, block % mesh) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call sw_compute_tend(tendPool, provisStatePool, meshPool, 1) + call sw_compute_scalar_tend(tendPool, provisStatePool, meshPool, 1) + call sw_enforce_boundary_edge(tendPool, meshPool) block => block % next end do ! --- update halos for prognostic variables - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % u) - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % h) - call mpas_dmpar_exch_halo_field(domain % blocklist % tend % tracers) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + + call mpas_pool_get_field(tendPool, 'u', uField) + call mpas_pool_get_field(tendPool, 'h', hField) + call mpas_pool_get_field(tendPool, 'tracers', tracersField) + + call mpas_dmpar_exch_halo_field(uField) + call mpas_dmpar_exch_halo_field(hField) + call mpas_dmpar_exch_halo_field(tracersField) ! --- compute next substep state if (rk_step < 4) then block => domain % blocklist do while (associated(block)) - block % provis_state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) & - + rk_substep_weights(rk_step) * block % tend % u % array(:,:) - block % provis_state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:) & - + rk_substep_weights(rk_step) * block % tend % h % array(:,:) - do iCell=1,block % mesh % nCells - do k=1,block % mesh % nVertLevels - block % provis_state % tracers % array(:,k,iCell) = ( block % state % time_levs(1) % state % h % array(k,iCell) * & - block % state % time_levs(1) % state % tracers % array(:,k,iCell) & - + rk_substep_weights(rk_step) * block % tend % tracers % array(:,k,iCell) & - ) / block % provis_state % h % array(k,iCell) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(provisStatePool, 'u', uProvis) + call mpas_pool_get_array(provisStatePool, 'h', hProvis) + call mpas_pool_get_array(provisStatePool, 'tracers', tracersProvis) + + call mpas_pool_get_array(statePool, 'u', uOld, 1) + call mpas_pool_get_array(statePool, 'h', hOld, 1) + call mpas_pool_get_array(statePool, 'tracers', tracersOld, 1) + + call mpas_pool_get_array(tendPool, 'u', uTend) + call mpas_pool_get_array(tendPool, 'h', hTend) + call mpas_pool_get_array(tendPool, 'tracers', tracersTend) + + uProvis(:,:) = uOld(:,:) + rk_substep_weights(rk_step) * uTend(:,:) + hProvis(:,:) = hOld(:,:) + rk_substep_weights(rk_step) * hTend(:,:) + do iCell = 1, nCells + do k = 1, nVertLevels + tracersProvis(:,k,iCell) = ( hOld(k,iCell) * tracersOld(:,k,iCell) & + + rk_substep_weights(rk_step) * tracersTend(:,k,iCell) & + ) / hProvis(k,iCell) end do end do if (config_test_case == 1) then ! For case 1, wind field should be fixed - block % provis_state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) + uProvis(:,:) = uOld(:,:) end if - call sw_compute_solve_diagnostics(dt, block % provis_state, block % mesh) + call sw_compute_solve_diagnostics(dt, provisStatePool, meshPool) block => block % next end do end if @@ -172,15 +281,30 @@ subroutine sw_rk4(domain, dt) block => domain % blocklist do while (associated(block)) - block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % u % array(:,:) & - + rk_weights(rk_step) * block % tend % u % array(:,:) - block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(2) % state % h % array(:,:) & - + rk_weights(rk_step) * block % tend % h % array(:,:) - do iCell=1,block % mesh % nCells - do k=1,block % mesh % nVertLevels - block % 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) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(statePool, 'u', uOld, 1) + call mpas_pool_get_array(statePool, 'h', hOld, 1) + call mpas_pool_get_array(statePool, 'tracers', tracersOld, 1) + + call mpas_pool_get_array(statePool, 'u', uNew, 2) + call mpas_pool_get_array(statePool, 'h', hNew, 2) + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + + call mpas_pool_get_array(tendPool, 'u', uTend) + call mpas_pool_get_array(tendPool, 'h', hTend) + call mpas_pool_get_array(tendPool, 'tracers', tracersTend) + + uNew(:,:) = uNew(:,:) + rk_weights(rk_step) * uTend(:,:) + hNew(:,:) = hNew(:,:) + rk_weights(rk_step) * hTend(:,:) + do iCell = 1, nCells + do k = 1, nVertLevels + tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersTend(:,k,iCell) end do end do block => block % next @@ -197,37 +321,58 @@ subroutine sw_rk4(domain, dt) ! block => domain % blocklist do while (associated(block)) - do iCell=1,block % mesh % nCells - do k=1,block % mesh % nVertLevels - 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) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(statePool, 'u', uOld, 1) + call mpas_pool_get_array(statePool, 'u', uNew, 2) + call mpas_pool_get_array(statePool, 'h', hNew, 2) + call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + + call mpas_pool_get_array(statePool, 'uReconstructX', uReconstructX, 2) + call mpas_pool_get_array(statePool, 'uReconstructY', uReconstructY, 2) + call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, 2) + call mpas_pool_get_array(statePool, 'uReconstructZonal', uReconstructZonal, 2) + call mpas_pool_get_array(statePool, 'uReconstructMeridional', uReconstructMeridional, 2) + + do iCell = 1, nCells + do k = 1, nVertLevels + tracersNew(:,k,iCell) = tracersNew(:,k,iCell) / hNew(k,iCell) end do end do 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(:,:) + uNew(:,:) = uOld(:,:) end if - call sw_compute_solve_diagnostics(dt, block % state % time_levs(2) % state, block % mesh) + call sw_compute_solve_diagnostics(dt, statePool, meshPool, 2) + + call mpas_reconstruct(meshPool, uNew, & + uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional ) + + block => block % next + end do + + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) - call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, & - block % state % time_levs(2) % state % uReconstructX % array, & - block % state % time_levs(2) % state % uReconstructY % array, & - block % state % time_levs(2) % state % uReconstructZ % array, & - block % state % time_levs(2) % state % uReconstructZonal % array, & - block % state % time_levs(2) % state % uReconstructMeridional % array & - ) + call mpas_pool_destroy_pool(provisStatePool) + call mpas_pool_remove_subpool(block % structs, 'provis_state') block => block % next end do - call mpas_deallocate_provis_state(domain % blocklist) + end subroutine sw_rk4 - subroutine sw_compute_tend(tend, s, grid) + subroutine sw_compute_tend(tendPool, statePool, meshPool, timeLevelIn) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Compute height and normal wind tendencies, as well as diagnostic variables ! @@ -239,14 +384,15 @@ subroutine sw_compute_tend(tend, s, grid) implicit none - type (tend_type), intent(inout) :: tend - type (state_type), intent(in) :: s - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(inout) :: tendPool + type (mpas_pool_type), intent(in) :: statePool + type (mpas_pool_type), intent(in) :: meshPool + integer, intent(in), optional :: timeLevelIn - integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j + integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, timeLevel real (kind=RKIND) :: flux, vorticity_abs, workpv, q, upstream_bias - integer :: nCells, nEdges, nVertices, nVertLevels + integer, pointer :: nCells, nEdges, nVertices, nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, & meshScalingDel2, meshScalingDel4 real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, & @@ -263,83 +409,96 @@ subroutine sw_compute_tend(tend, s, grid) real (kind=RKIND), parameter :: rho_ref = 1000.0 real (kind=RKIND) :: ke_edge + logical, pointer :: config_wind_stress, config_bottom_drag + real (kind=RKIND), pointer :: config_h_mom_eddy_visc2, config_h_mom_eddy_visc4 - h => s % h % array - u => s % u % 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 - pv_edge => s % pv_edge % array - vh => s % vh % 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 - edgesOnCell => grid % edgesOnCell % 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 - fEdge => grid % fEdge % array - - tend_h => tend % h % array - tend_u => tend % u % array - - nCells = grid % nCells - nEdges = grid % nEdges - nVertices = grid % nVertices - nVertLevels = grid % nVertLevels - - u_src => grid % u_src % array - - meshScalingDel2 => grid % meshScalingDel2 % array - meshScalingDel4 => grid % meshScalingDel4 % array + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + call mpas_pool_get_config(swConfigs, 'config_bottom_drag', config_bottom_drag) + call mpas_pool_get_config(swConfigs, 'config_wind_stress', config_wind_stress) + call mpas_pool_get_config(swConfigs, 'config_h_mom_eddy_visc2', config_h_mom_eddy_visc2) + call mpas_pool_get_config(swConfigs, 'config_h_mom_eddy_visc4', config_h_mom_eddy_visc4) + + call mpas_pool_get_array(statePool, 'h', h, timeLevel) + call mpas_pool_get_array(statePool, 'u', u, timeLevel) + call mpas_pool_get_array(statePool, 'v', v, timeLevel) + call mpas_pool_get_array(statePool, 'h_edge', h_edge, timeLevel) + call mpas_pool_get_array(statePool, 'circulation', circulation, timeLevel) + call mpas_pool_get_array(statePool, 'vorticity', vorticity, timeLevel) + call mpas_pool_get_array(statePool, 'divergence', divergence, timeLevel) + call mpas_pool_get_array(statePool, 'ke', ke, timeLevel) + call mpas_pool_get_array(statePool, 'pv_edge', pv_edge, timeLevel) + call mpas_pool_get_array(statePool, 'vh', vh, timeLevel) + + call mpas_pool_get_array(meshPool, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'h_s', h_s) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'u_src', u_src) + call mpas_pool_get_array(meshPool, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array(meshPool, 'meshScalingDel4', meshScalingDel4) + + call mpas_pool_get_array(tendPool, 'h', tend_h) + call mpas_pool_get_array(tendPool, 'u', tend_u) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) ! ! Compute height tendency for each cell ! tend_h(:,:) = 0.0 - do iEdge=1,nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - do k=1,nVertLevels + do k = 1, nVertLevels flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) tend_h(k,cell1) = tend_h(k,cell1) - flux tend_h(k,cell2) = tend_h(k,cell2) + flux end do end do - do iCell=1,grid % nCellsSolve - do k=1,nVertLevels + do iCell = 1, nCellsSolve + do k = 1, nVertLevels tend_h(k,iCell) = tend_h(k,iCell) / areaCell(iCell) end do end do -#ifdef LANL_FORMULATION + ! ! Compute u (normal) velocity tendency for each edge (cell face) ! tend_u(:,:) = 0.0 - do iEdge=1,grid % nEdgesSolve + do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) vertex1 = verticesOnEdge(1,iEdge) vertex2 = verticesOnEdge(2,iEdge) - do k=1,nVertLevels + do k = 1, nVertLevels q = 0.0 - do j = 1,nEdgesOnEdge(iEdge) + do j = 1, nEdgesOnEdge(iEdge) eoe = edgesOnEdge(j,iEdge) workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe)) q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe) @@ -354,44 +513,16 @@ subroutine sw_compute_tend(tend, s, grid) end do -#endif - -#ifdef NCAR_FORMULATION - ! - ! Compute u (normal) velocity tendency for each edge (cell face) - ! - tend_u(:,:) = 0.0 - do iEdge=1,grid % nEdgesSolve - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,nVertLevels - vorticity_abs = fEdge(iEdge) + (circulation(k,vertex1) + circulation(k,vertex2)) / & - (areaTriangle(vertex1) + areaTriangle(vertex2)) - - workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2)) - - tend_u(k,iEdge) = workpv * vh(k,iEdge) - & - (ke(k,cell2) - ke(k,cell1) + & - gravity * (h(k,cell2) + h_s(cell2) - h(k,cell1) - h_s(cell1)) & - ) / & - dcEdge(iEdge) - end do - end do -#endif - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity ! only valid for visc == constant if (config_h_mom_eddy_visc2 > 0.0) then - do iEdge=1,grid % nEdgesSolve + do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) vertex1 = verticesOnEdge(1,iEdge) vertex2 = verticesOnEdge(2,iEdge) - do k=1,nVertLevels + do k = 1, nVertLevels u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) & -(vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge) u_diffusion = meshScalingDel2(iEdge) * config_h_mom_eddy_visc2 * u_diffusion @@ -415,13 +546,13 @@ subroutine sw_compute_tend(tend, s, grid) delsq_u(:,:) = 0.0 ! Compute \nabla^2 u = \nabla divergence + k \times \nabla vorticity - do iEdge=1,grid % nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) vertex1 = verticesOnEdge(1,iEdge) vertex2 = verticesOnEdge(2,iEdge) - do k=1,nVertLevels + do k = 1, nVertLevels delsq_u(k,iEdge) = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) & -( vorticity(k,vertex2) - vorticity(k,vertex1)) / dvEdge(iEdge) @@ -431,7 +562,7 @@ subroutine sw_compute_tend(tend, s, grid) ! vorticity using \nabla^2 u delsq_circulation(:,:) = 0.0 - do iEdge=1,nEdges + do iEdge = 1, nEdges vertex1 = verticesOnEdge(1,iEdge) vertex2 = verticesOnEdge(2,iEdge) do k=1,nVertLevels @@ -441,16 +572,16 @@ subroutine sw_compute_tend(tend, s, grid) + dcEdge(iEdge) * delsq_u(k,iEdge) end do end do - do iVertex=1,nVertices + do iVertex = 1, nVertices r = 1.0 / areaTriangle(iVertex) - do k=1,nVertLevels + do k = 1, nVertLevels delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r end do end do ! Divergence using \nabla^2 u delsq_divergence(:,:) = 0.0 - do iEdge=1,nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) do k=1,nVertLevels @@ -462,20 +593,20 @@ subroutine sw_compute_tend(tend, s, grid) end do do iCell = 1,nCells r = 1.0 / areaCell(iCell) - do k = 1,nVertLevels + do k = 1, nVertLevels delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r end do end do ! Compute - \kappa \nabla^4 u ! as \nabla div(\nabla^2 u) + k \times \nabla ( k \cross curl(\nabla^2 u) ) - do iEdge=1,grid % nEdgesSolve + do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) vertex1 = verticesOnEdge(1,iEdge) vertex2 = verticesOnEdge(2,iEdge) - do k=1,nVertLevels + do k = 1, nVertLevels u_diffusion = ( delsq_divergence(k,cell2) & - delsq_divergence(k,cell1) ) / dcEdge(iEdge) & @@ -497,14 +628,14 @@ subroutine sw_compute_tend(tend, s, grid) ! Compute u (velocity) tendency from wind stress (u_src) if(config_wind_stress) then - do iEdge=1,grid % nEdges + do iEdge = 1, nEdges tend_u(1,iEdge) = tend_u(1,iEdge) & - + u_src(1,iEdge)/rho_ref/h_edge(1,iEdge) + + u_src(1,iEdge) / rho_ref / h_edge(1,iEdge) end do endif if (config_bottom_drag) then - do iEdge=1,grid % nEdges + do iEdge = 1, nEdges ! 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. @@ -520,7 +651,7 @@ subroutine sw_compute_tend(tend, s, grid) end subroutine sw_compute_tend - subroutine sw_compute_scalar_tend(tend, s, grid) + subroutine sw_compute_scalar_tend(tendPool, statePool, meshPool, timeLevelIn) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Input: s - current model state @@ -531,9 +662,10 @@ subroutine sw_compute_scalar_tend(tend, s, grid) implicit none - type (tend_type), intent(inout) :: tend - type (state_type), intent(in) :: s - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(inout) :: tendPool + type (mpas_pool_type), intent(in) :: statePool + type (mpas_pool_type), intent(in) :: meshPool + integer, intent(in), optional :: timeLevelIn integer :: iCell, iEdge, k, iTracer, cell1, cell2, i real (kind=RKIND) :: flux, tracer_edge, r @@ -550,37 +682,71 @@ subroutine sw_compute_scalar_tend(tend, s, grid) real (kind=RKIND) :: coef_3rd_order real (kind=RKIND), dimension(:,:), pointer :: u, h_edge - u => s % u % array - h_edge => s % h_edge % array - dcEdge => grid % dcEdge % array - deriv_two => grid % deriv_two % array - dvEdge => grid % dvEdge % array - tracers => s % tracers % array - cellsOnEdge => grid % cellsOnEdge % array - boundaryCell=> grid % boundaryCell % array - boundaryEdge=> grid % boundaryEdge % array - areaCell => grid % areaCell % array - tracer_tend => tend % tracers % array + integer, pointer :: config_tracer_adv_order + logical, pointer :: config_monotonic + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell + + integer, pointer :: nCells, nEdges, nVertices, nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nTracers + integer :: timeLevel + + real (kind=RKIND), pointer :: config_h_tracer_eddy_diff2, config_h_tracer_eddy_diff4 + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + endif + + call mpas_pool_get_config(swConfigs, 'config_tracer_adv_order', config_tracer_adv_order) + call mpas_pool_get_config(swConfigs, 'config_monotonic', config_monotonic) + call mpas_pool_get_config(swConfigs, 'config_h_tracer_eddy_diff2', config_h_tracer_eddy_diff2) + call mpas_pool_get_config(swConfigs, 'config_h_tracer_eddy_diff4', config_h_tracer_eddy_diff4) + + call mpas_pool_get_array(statePool, 'u', u, timeLevel) + call mpas_pool_get_array(statePool, 'h_edge', h_edge, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'deriv_two', deriv_two) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) + call mpas_pool_get_array(meshPool, 'boundaryEdge', boundaryEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + + call mpas_pool_get_array(tendPool, 'tracers', tracer_tend) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(meshPool, 'nTracers', nTracers) coef_3rd_order = 0. if (config_tracer_adv_order == 3) coef_3rd_order = 1.0 if (config_tracer_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25 - tracer_tend(:,:,:) = 0.0 if (config_tracer_adv_order == 2) then - do iEdge=1,grid % nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then - do k=1,grid % nVertLevels - do iTracer=1,grid % nTracers + if (cell1 <= nCells .and. cell2 <= nCells) then + do k = 1, nVertLevels + do iTracer = 1, nTracers tracer_edge = 0.5 * (tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) * tracer_edge - tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1) - tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2) + tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux / areaCell(cell1) + tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux / areaCell(cell2) end do end do end if @@ -588,36 +754,36 @@ subroutine sw_compute_scalar_tend(tend, s, grid) else if (config_tracer_adv_order == 3) then - do iEdge=1,grid%nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) !-- if a cell not on the most outside ring of the halo - if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then + if (cell1 <= nCells .and. cell2 <= nCells) then - do k=1,grid % nVertLevels + do k = 1, nVertLevels d2fdx2_cell1 = 0.0 d2fdx2_cell2 = 0.0 - do iTracer=1,grid % nTracers + do iTracer = 1, nTracers !-- if not a boundary cell - if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then + if(boundaryCell(k,cell1) .eq. 0 .and. boundaryCell(k,cell2) .eq. 0) then d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1) d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2) !-- all edges of cell 1 - do i=1, grid % nEdgesOnCell % array (cell1) + do i = 1, nEdgesOnCell(cell1) d2fdx2_cell1 = d2fdx2_cell1 + & - deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1)) + deriv_two(i+1,1,iEdge) * tracers(iTracer,k, CellsOnCell(i,cell1)) end do !-- all edges of cell 2 - do i=1, grid % nEdgesOnCell % array (cell2) + do i = 1, nEdgesOnCell(cell2) d2fdx2_cell2 = d2fdx2_cell2 + & - deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2)) + deriv_two(i+1,2,iEdge) * tracers(iTracer,k,CellsOnCell(i,cell2)) end do endif @@ -637,8 +803,8 @@ subroutine sw_compute_scalar_tend(tend, s, grid) end if !-- update tendency - tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1) - tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2) + tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux / areaCell(cell1) + tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux / areaCell(cell2) enddo end do end if @@ -646,36 +812,36 @@ subroutine sw_compute_scalar_tend(tend, s, grid) else if (config_tracer_adv_order == 4) then - do iEdge=1,grid%nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) !-- if an edge is not on the outer-most ring of the halo - if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then + if (cell1 <= nCells .and. cell2 <= nCells) then - do k=1,grid % nVertLevels + do k = 1, nVertLevels d2fdx2_cell1 = 0.0 d2fdx2_cell2 = 0.0 - do iTracer=1,grid % nTracers + do iTracer = 1, nTracers !-- if not a boundary cell - if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then + if(boundaryCell(k,cell1) .eq. 0 .and. boundaryCell(k,cell2) .eq. 0) then d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1) d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2) !-- all edges of cell 1 - do i=1, grid % nEdgesOnCell % array (cell1) + do i = 1, nEdgesOnCell(cell1) d2fdx2_cell1 = d2fdx2_cell1 + & - deriv_two(i+1,1,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell1)) + deriv_two(i+1,1,iEdge) * tracers(iTracer,k, cellsOnCell(i,cell1)) end do !-- all edges of cell 2 - do i=1, grid % nEdgesOnCell % array (cell2) + do i = 1, nEdgesOnCell(cell2) d2fdx2_cell2 = d2fdx2_cell2 + & - deriv_two(i+1,2,iEdge) * tracers(iTracer,k,grid % CellsOnCell % array (i,cell2)) + deriv_two(i+1,2,iEdge) * tracers(iTracer,k, cellsOnCell(i,cell2)) end do endif @@ -685,8 +851,8 @@ subroutine sw_compute_scalar_tend(tend, s, grid) -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. ) !-- update tendency - tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux/areaCell(cell1) - tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux/areaCell(cell2) + tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux / areaCell(cell1) + tracer_tend(iTracer,k,cell2) = tracer_tend(iTracer,k,cell2) + flux / areaCell(cell2) enddo end do end if @@ -702,18 +868,18 @@ subroutine sw_compute_scalar_tend(tend, s, grid) ! ! compute a boundary mask to enforce insulating boundary conditions in the horizontal ! - allocate(boundaryMask(grid % nVertLevels, grid % nEdges+1)) + allocate(boundaryMask(nVertLevels, nEdges+1)) boundaryMask = 1.0 where(boundaryEdge.eq.1) boundaryMask=0.0 - do iEdge=1,grid % nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) invAreaCell1 = 1.0/areaCell(cell1) invAreaCell2 = 1.0/areaCell(cell2) - do k=1,grid % nVertLevels - do iTracer=1, grid % nTracers + do k = 1, nVertLevels + do iTracer = 1, nTracers ! \kappa_2 \nabla \phi on edge tracer_turb_flux = config_h_tracer_eddy_diff2 & *( tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) @@ -740,21 +906,21 @@ subroutine sw_compute_scalar_tend(tend, s, grid) ! ! compute a boundary mask to enforce insulating boundary conditions in the horizontal ! - allocate(boundaryMask(grid % nVertLevels, grid % nEdges+1)) + allocate(boundaryMask(nVertLevels, nEdges+1)) boundaryMask = 1.0 where(boundaryEdge.eq.1) boundaryMask=0.0 - allocate(delsq_tracer(grid % nTracers, grid % nVertLevels, grid % nCells+1)) + allocate(delsq_tracer(nTracers, nVertLevels, nCells+1)) delsq_tracer(:,:,:) = 0. ! first del2: div(h \nabla \phi) at cell center - do iEdge=1,grid % nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - do k=1,grid % nVertLevels - do iTracer=1, grid % nTracers + do k = 1, nVertLevels + do iTracer = 1, nTracers delsq_tracer(iTracer,k,cell1) = delsq_tracer(iTracer,k,cell1) & + dvEdge(iEdge) * h_edge(k,iEdge) * (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) * boundaryMask(k,iEdge) delsq_tracer(iTracer,k,cell2) = delsq_tracer(iTracer,k,cell2) & @@ -764,24 +930,24 @@ subroutine sw_compute_scalar_tend(tend, s, grid) end do - do iCell = 1, grid % nCells - r = 1.0 / grid % areaCell % array(iCell) - do k=1,grid % nVertLevels - do iTracer=1,grid % nTracers + do iCell = 1, nCells + r = 1.0 / areaCell(iCell) + do k = 1, nVertLevels + do iTracer = 1, nTracers delsq_tracer(iTracer,k,iCell) = delsq_tracer(iTracer,k,iCell) * r end do end do end do ! second del2: div(h \nabla [delsq_tracer]) at cell center - do iEdge=1,grid % nEdges - cell1 = grid % cellsOnEdge % array(1,iEdge) - cell2 = grid % cellsOnEdge % array(2,iEdge) - invAreaCell1 = 1.0 / grid % areaCell % array(cell1) - invAreaCell2 = 1.0 / grid % areaCell % array(cell2) - - do k=1,grid % nVertLevels - do iTracer=1,grid % nTracers + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + invAreaCell1 = 1.0 / areaCell(cell1) + invAreaCell2 = 1.0 / areaCell(cell2) + + do k = 1, nVertLevels + do iTracer = 1, nTracers tracer_turb_flux = config_h_tracer_eddy_diff4 * (delsq_tracer(iTracer,k,cell2) - delsq_tracer(iTracer,k,cell1)) / dcEdge(iEdge) flux = dvEdge(iEdge) * tracer_turb_flux tracer_tend(iTracer,k,cell1) = tracer_tend(iTracer,k,cell1) - flux * invAreaCell1 * boundaryMask(k,iEdge) @@ -799,7 +965,7 @@ subroutine sw_compute_scalar_tend(tend, s, grid) end subroutine sw_compute_scalar_tend - subroutine sw_compute_solve_diagnostics(dt, s, grid) + subroutine sw_compute_solve_diagnostics(dt, statePool, meshPool, timeLevelIn) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Compute diagnostic fields used in the tendency computations ! @@ -811,77 +977,95 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) implicit none real (kind=RKIND), intent(in) :: dt - type (state_type), intent(inout) :: s - type (mesh_type), intent(in) :: grid - + type (mpas_pool_type), intent(inout) :: statePool + type (mpas_pool_type), intent(in) :: meshPool + integer, intent(in), optional :: timeLevelIn integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov real (kind=RKIND) :: flux, vorticity_abs, workpv - integer :: nCells, nEdges, nVertices, nVertLevels + integer, pointer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, & circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, divergence, & h_vertex, vorticity_cell - integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge, boundaryCell + integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, boundaryEdge, boundaryCell, cellsOnCell integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge real (kind=RKIND) :: r, h1, h2 real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2 real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two real (kind=RKIND) :: coef_3rd_order - h => s % h % array - u => s % u % array - v => s % v % array - vh => s % vh % array - h_edge => s % h_edge % array - h_vertex => s % h_vertex % array - tend_h => s % h % array - tend_u => s % u % array - circulation => s % circulation % array - vorticity => s % vorticity % array - divergence => s % divergence % array - ke => s % ke % array - pv_edge => s % pv_edge % array - pv_vertex => s % pv_vertex % array - pv_cell => s % pv_cell % array - vorticity_cell => s % vorticity_cell % array - gradPVn => s % gradPVn % array - gradPVt => s % gradPVt % 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 - edgesOnCell => grid % edgesOnCell % 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 - fEdge => grid % fEdge % array - deriv_two => grid % deriv_two % array + integer :: timeLevel + + logical, pointer :: config_monotonic + integer, pointer :: config_thickness_adv_order + real (kind=RKIND), pointer :: config_apvm_upwinding + + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + call mpas_pool_get_config(swConfigs, 'config_monotonic', config_monotonic) + call mpas_pool_get_config(swConfigs, 'config_thickness_adv_order', config_thickness_adv_order) + call mpas_pool_get_config(swConfigs, 'config_apvm_upwinding', config_apvm_upwinding) + + call mpas_pool_get_array(statePool, 'h', h, timeLevel) + call mpas_pool_get_array(statePool, 'u', u, timeLevel) + call mpas_pool_get_array(statePool, 'v', v, timeLevel) + call mpas_pool_get_array(statePool, 'vh', vh, timeLevel) + call mpas_pool_get_array(statePool, 'h_edge', h_edge, timeLevel) + call mpas_pool_get_array(statePool, 'h_vertex', h_vertex, timeLevel) + call mpas_pool_get_array(statePool, 'h', tend_h, timeLevel) + call mpas_pool_get_array(statePool, 'u', tend_u, timeLevel) + call mpas_pool_get_array(statePool, 'circulation', circulation, timeLevel) + call mpas_pool_get_array(statePool, 'vorticity', vorticity, timeLevel) + call mpas_pool_get_array(statePool, 'divergence', divergence, timeLevel) + call mpas_pool_get_array(statePool, 'ke', ke, timeLevel) + call mpas_pool_get_array(statePool, 'pv_edge', pv_edge, timeLevel) + call mpas_pool_get_array(statePool, 'pv_vertex', pv_vertex, timeLevel) + call mpas_pool_get_array(statePool, 'pv_cell', pv_cell, timeLevel) + call mpas_pool_get_array(statePool, 'vorticity_cell', vorticity_cell, timeLevel) + call mpas_pool_get_array(statePool, 'gradPVn', gradPVn, timeLevel) + call mpas_pool_get_array(statePool, 'gradPVt', gradPVt, timeLevel) + + call mpas_pool_get_array(meshPool, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'h_s', h_s) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'deriv_two', deriv_two) - nCells = grid % nCells - nEdges = grid % nEdges - nVertices = grid % nVertices - nVertLevels = grid % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) - boundaryEdge => grid % boundaryEdge % array - boundaryCell => grid % boundaryCell % array + call mpas_pool_get_array(meshPool, 'boundaryEdge', boundaryEdge) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) ! ! Find those cells that have an edge on the boundary ! boundaryCell(:,:) = 0 - do iEdge=1,nEdges - do k=1,nVertLevels + do iEdge = 1, nEdges + do k = 1, nVertLevels if(boundaryEdge(k,iEdge).eq.1) then cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -902,11 +1086,11 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) if (config_thickness_adv_order == 2) then - do iEdge=1,grid % nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then - do k=1,grid % nVertLevels + if (cell1 <= nCells .and. cell2 <= nCells) then + do k = 1, nVertLevels h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2)) end do end if @@ -914,34 +1098,34 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) else if (config_thickness_adv_order == 3) then - do iEdge=1,grid%nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) !-- if a cell not on the most outside ring of the halo - if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then + if (cell1 <= nCells .and. cell2 <= nCells) then - do k=1,grid % nVertLevels + do k = 1, nVertLevels d2fdx2_cell1 = 0.0 d2fdx2_cell2 = 0.0 !-- if not a boundary cell - if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then + if(boundaryCell(k,cell1) .eq. 0 .and. boundaryCell(k,cell2) .eq. 0) then d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1) d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2) !-- all edges of cell 1 - do i=1, grid % nEdgesOnCell % array (cell1) + do i = 1, nEdgesOnCell(cell1) d2fdx2_cell1 = d2fdx2_cell1 + & - deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1)) + deriv_two(i+1,1,iEdge) * h(k, cellsOnCell(i,cell1)) end do !-- all edges of cell 2 - do i=1, grid % nEdgesOnCell % array (cell2) + do i = 1, nEdgesOnCell(cell2) d2fdx2_cell2 = d2fdx2_cell2 + & - deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2)) + deriv_two(i+1,2,iEdge) * h(k, cellsOnCell(i,cell2)) end do endif @@ -966,34 +1150,34 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) else if (config_thickness_adv_order == 4) then - do iEdge=1,grid%nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) !-- if a cell not on the most outside ring of the halo - if (cell1 <= grid%nCells .and. cell2 <= grid%nCells) then + if (cell1 <= nCells .and. cell2 <= nCells) then - do k=1,grid % nVertLevels + do k = 1, nVertLevels d2fdx2_cell1 = 0.0 d2fdx2_cell2 = 0.0 !-- if not a boundary cell - if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then + if(boundaryCell(k,cell1) .eq. 0 .and. boundaryCell(k,cell2) .eq. 0) then d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1) d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2) !-- all edges of cell 1 - do i=1, grid % nEdgesOnCell % array (cell1) + do i = 1, nEdgesOnCell(cell1) d2fdx2_cell1 = d2fdx2_cell1 + & - deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1)) + deriv_two(i+1,1,iEdge) * h(k, cellsOnCell(i,cell1)) end do !-- all edges of cell 2 - do i=1, grid % nEdgesOnCell % array (cell2) + do i = 1, nEdgesOnCell(cell2) d2fdx2_cell2 = d2fdx2_cell2 + & - deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2)) + deriv_two(i+1,2,iEdge) * h(k, cellsOnCell(i,cell2)) end do endif @@ -1018,14 +1202,14 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! Compute circulation and relative vorticity at each vertex ! circulation(:,:) = 0.0 - do iEdge=1,nEdges - do k=1,nVertLevels + do iEdge = 1, nEdges + do k = 1, nVertLevels circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge) circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge) end do end do - do iVertex=1,nVertices - do k=1,nVertLevels + do iVertex = 1, nVertices + do k = 1, nVertLevels vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex) end do end do @@ -1035,23 +1219,23 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! Compute the divergence at each cell center ! divergence(:,:) = 0.0 - do iEdge=1,nEdges + do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) if (cell1 <= nCells) then - do k=1,nVertLevels + do k = 1, nVertLevels divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge) enddo endif if(cell2 <= nCells) then - do k=1,nVertLevels + do k = 1, nVertLevels divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge) enddo end if end do - do iCell = 1,nCells + do iCell = 1, nCells r = 1.0 / areaCell(iCell) - do k = 1,nVertLevels + do k = 1, nVertLevels divergence(k,iCell) = divergence(k,iCell) * r enddo enddo @@ -1060,14 +1244,14 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! Compute kinetic energy in each cell ! ke(:,:) = 0.0 - do iCell=1,nCells - do i=1,nEdgesOnCell(iCell) + do iCell = 1, nCells + do i = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) - do k=1,nVertLevels + do k = 1, nVertLevels ke(k,iCell) = ke(k,iCell) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0 end do end do - do k=1,nVertLevels + do k = 1, nVertLevels ke(k,iCell) = ke(k,iCell) / areaCell(iCell) end do end do @@ -1077,7 +1261,7 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! v(:,:) = 0.0 do iEdge = 1,nEdges - do i=1,nEdgesOnEdge(iEdge) + do i = 1, nEdgesOnEdge(iEdge) eoe = edgesOnEdge(i,iEdge) do k = 1,nVertLevels v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe) @@ -1090,10 +1274,10 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells) ! vh(:,:) = 0.0 - do iEdge=1,grid % nEdgesSolve - do j=1,nEdgesOnEdge(iEdge) + do iEdge = 1, nEdgesSolve + do j = 1, nEdgesOnEdge(iEdge) eoe = edgesOnEdge(j,iEdge) - do k=1,nVertLevels + do k = 1, nVertLevels vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe) end do end do @@ -1106,9 +1290,9 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! ( this computes pv_vertex at all vertices bounding real cells and distance-1 ghost cells ) ! do iVertex = 1,nVertices - do k=1,nVertLevels + do k = 1, nVertLevels h_vertex(k,iVertex) = 0.0 - do i=1,grid % vertexDegree + do i = 1, vertexDegree h_vertex(k,iVertex) = h_vertex(k,iVertex) + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex) end do h_vertex(k,iVertex) = h_vertex(k,iVertex) / areaTriangle(iVertex) @@ -1122,8 +1306,8 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! Compute gradient of PV in the tangent direction ! ( this computes gradPVt at all edges bounding real cells and distance-1 ghost cells ) ! - do iEdge = 1,nEdges - do k = 1,nVertLevels + do iEdge = 1, nEdges + do k = 1, nVertLevels gradPVt(k,iEdge) = (pv_vertex(k,verticesOnEdge(2,iEdge)) - pv_vertex(k,verticesOnEdge(1,iEdge))) / & dvEdge(iEdge) enddo @@ -1135,9 +1319,9 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! pv_edge(:,:) = 0.0 do iVertex = 1,nVertices - do i=1,grid % vertexDegree + do i = 1, vertexDegree iEdge = edgesOnVertex(i,iVertex) - do k=1,nVertLevels + do k = 1, nVertLevels pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex) end do end do @@ -1147,8 +1331,8 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! ! Modify PV edge with upstream bias. ! - do iEdge = 1,nEdges - do k = 1,nVertLevels + do iEdge = 1, nEdges + do k = 1, nVertLevels pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * v(k,iEdge) * dt * gradPVt(k,iEdge) enddo enddo @@ -1161,10 +1345,10 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) pv_cell(:,:) = 0.0 vorticity_cell(:,:) = 0.0 do iVertex = 1, nVertices - do i=1,grid % vertexDegree + do i = 1, vertexDegree iCell = cellsOnVertex(i,iVertex) if (iCell <= nCells) then - do k = 1,nVertLevels + do k = 1, nVertLevels pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell) vorticity_cell(k,iCell) = vorticity_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * vorticity(k, iVertex) / areaCell(iCell) enddo @@ -1178,9 +1362,9 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! ( this computes gradPVn for all edges bounding real cells ) ! gradPVn(:,:) = 0.0 - do iEdge = 1,nEdges + do iEdge = 1, nEdges if( cellsOnEdge(1,iEdge) <= nCells .and. cellsOnEdge(2,iEdge) <= nCells) then - do k = 1,nVertLevels + do k = 1, nVertLevels gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / & dcEdge(iEdge) enddo @@ -1189,8 +1373,8 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) ! Modify PV edge with upstream bias. ! - do iEdge = 1,nEdges - do k = 1,nVertLevels + do iEdge = 1, nEdges + do k = 1, nVertLevels pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * u(k,iEdge) * dt * gradPVn(k,iEdge) enddo enddo @@ -1223,7 +1407,7 @@ subroutine sw_compute_solve_diagnostics(dt, s, grid) end subroutine sw_compute_solve_diagnostics - subroutine sw_enforce_boundary_edge(tend, grid) + subroutine sw_enforce_boundary_edge(tendPool, meshPool) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Enforce any boundary conditions on the normal velocity at each edge ! @@ -1235,26 +1419,26 @@ subroutine sw_enforce_boundary_edge(tend, grid) implicit none - type (tend_type), intent(inout) :: tend - type (mesh_type), intent(in) :: grid + type (mpas_pool_type), intent(inout) :: tendPool + type (mpas_pool_type), intent(in) :: meshPool integer, dimension(:,:), pointer :: boundaryEdge real (kind=RKIND), dimension(:,:), pointer :: tend_u - integer :: nCells, nEdges, nVertices, nVertLevels + integer, pointer :: nCells, nEdges, nVertices, nVertLevels integer :: iEdge, k - nCells = grid % nCells - nEdges = grid % nEdges - nVertices = grid % nVertices - nVertLevels = grid % nVertLevels + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - boundaryEdge => grid % boundaryEdge % array - tend_u => tend % u % array + call mpas_pool_get_array(meshPool, 'boundaryEdge', boundaryEdge) + call mpas_pool_get_array(tendPool, 'u', tend_u) if(maxval(boundaryEdge).le.0) return - do iEdge = 1,nEdges - do k = 1,nVertLevels + do iEdge = 1, nEdges + do k = 1, nVertLevels if(boundaryEdge(k,iEdge).eq.1) then tend_u(k,iEdge) = 0.0 diff --git a/src/driver/Makefile b/src/driver/Makefile index abfb95d71d..7a803c72c1 100644 --- a/src/driver/Makefile +++ b/src/driver/Makefile @@ -3,7 +3,11 @@ OBJS = mpas_subdriver.o \ mpas.o -all: $(OBJS) +all: + ($(MAKE) clean) + ($(MAKE) driver) + +driver: $(OBJS) mpas_subdriver.o: @@ -11,6 +15,9 @@ mpas.o: mpas_subdriver.o clean: $(RM) *.o *.mod *.f90 + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: $(RM) $@ $*.mod diff --git a/src/driver/mpas_subdriver.F b/src/driver/mpas_subdriver.F index bb0386afd8..f6a6d645ec 100644 --- a/src/driver/mpas_subdriver.F +++ b/src/driver/mpas_subdriver.F @@ -11,53 +11,126 @@ module mpas_subdriver use mpas_core use mpas_kind_types + ! TODO: This should be moved inside the domain type? + ! Unless we re-arrange modules, doing so would create a circular dependence + ! between the mpas_grid_types and mpas_stream_manager modules. + use mpas_stream_manager, only : MPAS_streamManager_type + type (dm_info), pointer :: dminfo - type (domain_type), pointer :: domain - type (io_output_object), save :: output_obj - integer :: output_frame + type (domain_type), save, target :: domain + type (domain_type), pointer :: domain_ptr + + ! TODO: This should be moved inside the domain type? + ! Unless we re-arrange modules, doing so would create a circular dependence + ! between the mpas_grid_types and mpas_stream_manager modules. + type (MPAS_streamManager_type), pointer :: stream_manager contains subroutine mpas_init() + + use mpas_stream_manager, only : MPAS_stream_mgr_init + use iso_c_binding, only : c_char, c_loc, c_ptr, c_int + use mpas_c_interfacing, only : mpas_f_to_c_string, mpas_c_to_f_string + use mpas_timekeeping, only : MPAS_Time_type, mpas_get_clock_time, mpas_get_time + use mpas_bootstrapping, only : mpas_bootstrap_framework, mpas_setup_immutable_streams implicit none character(len=StrKIND) :: timeStamp integer :: ierr + character(kind=c_char), dimension(StrKIND+1) :: c_filename ! StrKIND+1 for C null-termination character + integer(kind=c_int) :: c_comm + integer(kind=c_int) :: c_ierr + type (c_ptr) :: mgr_p + character(len=StrKIND) :: mesh_stream + character(len=StrKIND) :: mesh_filename + character(len=StrKIND) :: mesh_filename_temp + character(kind=c_char), dimension(StrKIND+1) :: c_mesh_stream + character(kind=c_char), dimension(StrKIND+1) :: c_mesh_filename_temp + type (MPAS_Time_type) :: start_time + character(len=StrKIND) :: start_timestamp + + + interface + subroutine xml_stream_parser(xmlname, mgr_p, comm, ierr) bind(c) + use iso_c_binding, only : c_char, c_ptr, c_int + character(kind=c_char), dimension(*), intent(in) :: xmlname + type (c_ptr), intent(inout) :: mgr_p + integer(kind=c_int), intent(inout) :: comm + integer(kind=c_int), intent(out) :: ierr + end subroutine xml_stream_parser + + subroutine xml_stream_get_filename(xmlname, streamname, comm, filename, ierr) bind(c) + use iso_c_binding, only : c_char, c_int + character(kind=c_char), dimension(*), intent(in) :: xmlname + character(kind=c_char), dimension(*), intent(in) :: streamname + integer(kind=c_int), intent(inout) :: comm + character(kind=c_char), dimension(*), intent(in) :: filename + integer(kind=c_int), intent(out) :: ierr + end subroutine xml_stream_get_filename + end interface + + + domain_ptr => domain + ! ! Initialize infrastructure ! - call mpas_framework_init(dminfo, domain) - call mpas_core_setup_packages(ierr) + call mpas_framework_init(dminfo, domain_ptr) + call mpas_core_setup_packages(domain_ptr % configs, domain_ptr % packages, ierr) + call mpas_core_setup_clock(domain_ptr % clock, domain_ptr % configs, ierr) - call mpas_timer_start("total time") - call mpas_timer_start("initialize") + call mpas_timer_start('total time') + call mpas_timer_start('initialize') - call mpas_input_state_for_domain(domain) + ! + ! Using information from the namelist, a graph.info file, and a file containing + ! mesh fields, build halos and allocate blocks in the domain + ! + call mpas_core_get_mesh_stream(domain_ptr % configs, mesh_stream, ierr) + if (ierr /= 0) then + call mpas_dmpar_abort(dminfo) + end if + call mpas_f_to_c_string(domain % streams_filename, c_filename) + call mpas_f_to_c_string(mesh_stream, c_mesh_stream) + c_comm = dminfo % comm + call xml_stream_get_filename(c_filename, c_mesh_stream, c_comm, c_mesh_filename_temp, c_ierr) + if (c_ierr /= 0) then + call mpas_dmpar_abort(dminfo) + end if + call mpas_c_to_f_string(c_mesh_filename_temp, mesh_filename_temp) + start_time = mpas_get_clock_time(domain_ptr % clock, MPAS_START_TIME, ierr) + call mpas_get_time(start_time, dateTimeString=start_timestamp, ierr=ierr) + call mpas_expand_string(start_timestamp, mesh_filename_temp, mesh_filename) + call mpas_bootstrap_framework(domain_ptr, mesh_filename) ! - ! Initialize core + ! Set up run-time streams ! - call mpas_core_init(domain, timeStamp) + call MPAS_stream_mgr_init(stream_manager, domain % clock, domain % blocklist % allFields, domain % packages, domain % blocklist % allStructs) + + call add_stream_attributes(stream_manager, domain) - call mpas_timer_stop("initialize") + call mpas_setup_immutable_streams(stream_manager) + + mgr_p = c_loc(stream_manager) + call xml_stream_parser(c_filename, mgr_p, c_comm, c_ierr) + if (c_ierr /= 0) then + call mpas_dmpar_abort(dminfo) + end if ! - ! Set up output streams to be written to by the MPAS core + ! Initialize core ! - output_frame = 1 - - if(config_frames_per_outfile > 0) then - call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) - else - call mpas_output_state_init(output_obj, domain, "OUTPUT") - end if + call mpas_core_init(domain_ptr, stream_manager, timeStamp) + call mpas_timer_stop('initialize') end subroutine mpas_init @@ -66,35 +139,111 @@ subroutine mpas_run() implicit none - call mpas_core_run(domain, output_obj, output_frame) + call mpas_core_run(domain_ptr, stream_manager) end subroutine mpas_run subroutine mpas_finalize() + + use mpas_stream_manager, only : MPAS_stream_mgr_finalize implicit none - ! - ! Finalize output streams - ! - call mpas_output_state_finalize(output_obj, domain % dminfo) - ! ! Finalize core ! - call mpas_core_finalize(domain) + call mpas_core_finalize(domain_ptr, stream_manager) - call mpas_timer_stop("total time") + call mpas_timer_stop('total time') call mpas_timer_write() ! ! Finalize infrastructure ! - call mpas_framework_finalize(dminfo, domain) + call MPAS_stream_mgr_finalize(stream_manager) + + call mpas_framework_finalize(dminfo, domain_ptr) end subroutine mpas_finalize + + subroutine add_stream_attributes(stream_manager, domain) + + use mpas_stream_manager, only : MPAS_stream_mgr_add_att + + implicit none + + type (MPAS_streamManager_type), intent(inout) :: stream_manager + type (domain_type), intent(inout) :: domain + + type (MPAS_Pool_iterator_type) :: itr + integer, pointer :: intAtt + logical, pointer :: logAtt + character (len=StrKIND), pointer :: charAtt + real (kind=RKIND), pointer :: realAtt + character (len=StrKIND) :: histAtt + + integer :: local_ierr + + if (domain % dminfo % nProcs < 10) then + write(histAtt, '(A,I1,A,A,A)') 'mpirun -n ', domain % dminfo % nProcs, ' ./', trim(domain % coreName), '_model' + else if (domain % dminfo % nProcs < 100) then + write(histAtt, '(A,I2,A,A,A)') 'mpirun -n ', domain % dminfo % nProcs, ' ./', trim(domain % coreName), '_model' + else if (domain % dminfo % nProcs < 1000) then + write(histAtt, '(A,I3,A,A,A)') 'mpirun -n ', domain % dminfo % nProcs, ' ./', trim(domain % coreName), '_model' + else if (domain % dminfo % nProcs < 10000) then + write(histAtt, '(A,I4,A,A,A)') 'mpirun -n ', domain % dminfo % nProcs, ' ./', trim(domain % coreName), '_model' + else if (domain % dminfo % nProcs < 100000) then + write(histAtt, '(A,I5,A,A,A)') 'mpirun -n ', domain % dminfo % nProcs, ' ./', trim(domain % coreName), '_model' + else + write(histAtt, '(A,I6,A,A,A)') 'mpirun -n ', domain % dminfo % nProcs, ' ./', trim(domain % coreName), '_model' + end if + + + call MPAS_stream_mgr_add_att(stream_manager, 'on_a_sphere', domain % on_a_sphere) + call MPAS_stream_mgr_add_att(stream_manager, 'sphere_radius', domain % sphere_radius) + call MPAS_stream_mgr_add_att(stream_manager, 'model_name', domain % modelName) + call MPAS_stream_mgr_add_att(stream_manager, 'core_name', domain % coreName) + ! DWJ 10/01/2014: Eventually add the real history attribute, for now (due to length restrictions) + ! add a shortened version. +! call MPAS_stream_mgr_add_att(stream_manager, 'history', domain % history) + call MPAS_stream_mgr_add_att(stream_manager, 'history', histAtt) + call MPAS_stream_mgr_add_att(stream_manager, 'source', domain % source) + call MPAS_stream_mgr_add_att(stream_manager, 'Conventions', domain % Conventions) + call MPAS_stream_mgr_add_att(stream_manager, 'parent_id', domain % parent_id) + call MPAS_stream_mgr_add_att(stream_manager, 'mesh_spec', domain % mesh_spec) + call MPAS_stream_mgr_add_att(stream_manager, 'git_version', domain % git_version) + + call mpas_pool_begin_iteration(domain % configs) + + do while (mpas_pool_get_next_member(domain % configs, itr)) + + if ( itr % memberType == MPAS_POOL_CONFIG) then + + if ( itr % dataType == MPAS_POOL_REAL ) then + call mpas_pool_get_config(domain % configs, itr % memberName, realAtt) + call MPAS_stream_mgr_add_att(stream_manager, itr % memberName, realAtt, ierr=local_ierr) + else if ( itr % dataType == MPAS_POOL_INTEGER ) then + call mpas_pool_get_config(domain % configs, itr % memberName, intAtt) + call MPAS_stream_mgr_add_att(stream_manager, itr % memberName, intAtt, ierr=local_ierr) + else if ( itr % dataType == MPAS_POOL_CHARACTER ) then + call mpas_pool_get_config(domain % configs, itr % memberName, charAtt) + call MPAS_stream_mgr_add_att(stream_manager, itr % memberName, charAtt, ierr=local_ierr) + else if ( itr % dataType == MPAS_POOL_LOGICAL ) then + call mpas_pool_get_config(domain % configs, itr % memberName, logAtt) + if (logAtt) then + call MPAS_stream_mgr_add_att(stream_manager, itr % memberName, 'YES', ierr=local_ierr) + else + call MPAS_stream_mgr_add_att(stream_manager, itr % memberName, 'NO', ierr=local_ierr) + end if + end if + + end if + end do + + end subroutine add_stream_attributes + end module mpas_subdriver diff --git a/src/external/Makefile b/src/external/Makefile index ed09356d78..0fbe18393d 100644 --- a/src/external/Makefile +++ b/src/external/Makefile @@ -3,7 +3,7 @@ all: esmf_time esmf_time: - ( cd esmf_time_f90; $(MAKE) FC="$(FC) $(FFLAGS)" CPP="$(CPP)" ) + ( cd esmf_time_f90; $(MAKE) FC="$(FC) $(FFLAGS)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS) -DHIDE_MPI" ) clean: ( cd esmf_time_f90; $(MAKE) clean ) diff --git a/src/external/esmf_time_f90/ChangeLog b/src/external/esmf_time_f90/ChangeLog new file mode 100644 index 0000000000..239a95de94 --- /dev/null +++ b/src/external/esmf_time_f90/ChangeLog @@ -0,0 +1,167 @@ +=============================================================== +Originator: douglasj +Date: Sept 17, 2014 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_140529 +One-line Summary: Adding a Makefile to build ESMF into a library (libesmf_time.a) + +A Makefile +=============================================================== +Originator: muszala +Date: May 29, 2014 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_140529 +One-line Summary: change deallocate statements in ESMF_ClockMod.F90 + +M ESMF_ClockMod.F90 +=============================================================== +Originator: muszala +Date: May 23, 2014 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_140523 +One-line Summary: add if(associated) to ESMF_ClockDestroy + +Note: use with rtm1_0_38 and tested with clm4_5_72. this should work with older +versions of clm and rtm however. + +M ESMF_ClockMod.F90 +=============================================================== +Originator: santos +Date: Feb 13, 2012 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_130213 +One-line Summary: Update for NAG port. + +- svn merge $SVNREPO/esmf_wrf_timemgr/trunk_tags/esmf_wrf_timemgr_120427 $SVNREPO/esmf_wrf_timemgr/branch_tags/nag_port_tags/nag_port_n01_esmf_wrf_timemgr_120427 +M ESMF_ShrTimeMod.F90 +M ESMF_ClockMod.F90 +M ESMF_AlarmMod.F90 +M ESMF_TimeMod.F90 +=============================================================== +Originator: tcraig +Date: Apr 27 2012 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_120427 +One-line Summary: add ShrTimeMod to ESMF.F90 module for use in wrf + +M ESMF.F90 +=============================================================== +Originator: tcraig +Date: Apr 13 2012 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_120413 +One-line Summary: Remove dead code and minor mods for wrf usage + +M ESMF.F90 +M wrf_message.F90 +M ESMF_TimeMod.F90 +M ESMF_TimeIntervalMod.F90 +M wrf_error_fatal.F90 +=============================================================== +Originator: fischer +Date: Apr 4 2012 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_120404 +One-line Summary: Change type ESMF_DaysPerYear from private to public + +M ESMF_CalendarMod.F90 +=============================================================== +Originator: tcraig +Date: Mar 27 2012 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_120327 +One-line Summary: update TimeInc and TimeDiff to improve performance + and make calculation more consistent with ESMF. + +M unittests/test.F90 +M unittests/test.out.base +M ESMF_TimeMod.F90 +M ESMF_TimeIntervalMod.F90 +=============================================================== +Originator: tcraig +Date: Feb 18 2012 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_120218 +One-line Summary: significant refactor to support multiple calendars + at the same time. + +M ESMF_CalendarMod.F90 +A + ESMF_ShrTimeMod.F90 +D Meat.F90 +A + MeatMod.F90 +M ESMF_TimeMgr.inc +A + README +M ESMF_BaseTimeMod.F90 +D ESMF.inc +A + unittests/go.csh +D unittests/Depends +D unittests/ESMF.inc +A + unittests/wrf_stuff.F90 +D unittests/Test1.out.correct.noleap +D unittests/testall.csh +D unittests/Test1.out.correct +D unittests/standard.sed +A + unittests/test.F90 +M unittests/Makefile +D unittests/Test1.F90 +A + unittests/test.out.base +M ESMF_TimeMod.F90 +M ESMF_Stubs.F90 +M ESMF_TimeIntervalMod.F90 +=============================================================== +Originator: tcraig +Date: Jan 23 2012 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_120123 +One-line Summary: update for esmf 520r including change from + "use esmf_mod" to "use esmf" + +M ESMF_CalendarMod.F90 +D ESMF_Mod.F90 +A + ESMF.F90 +M unittests/Test1.F90 +M ESMF_Stubs.F90 +=============================================================== +Originator: tcraig +Date: Oct 18, 2010 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_101018 +One-line Summary: merge racm03_esmf_wrf_timemgr_090402 to trunk + +- fix circular logic related to defaultCal. +- make more routines public. +- add some methods. +- add WRFADDITION interfaces for wrf. these are + modifications of some of the current interfaces for + use in WRF. These need to be reconciled to be used + with the ESMF library. +- also add support for d_ in ESMF_TimeIntervalSet for CAM. + +M ESMF_TimeMgr.inc +M ESMF_TimeMod.F90 +M ESMF_TimeIntervalMod.F90 +M ESMF_CalendarMod.F90 +M ESMF_Stubs.F90 + +=============================================================== +Originator: tcraig +Date: Apr 2, 2009 +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_090402 +One-line Summary: Add alarmcount to ESMF_ClockGet interface + +Required to support alarms properly in ccsm4 +Also add ChangeLog + +A ChangeLog +M ESMF_ClockMod.F90 + +=============================================================== + +Originator: +Date: +Model: esmf_wrf_timemgr +Version: esmf_wrf_timemgr_080717 +One-line Summary: + +=============================================================== diff --git a/src/external/esmf_time_f90/ESMF.F90 b/src/external/esmf_time_f90/ESMF.F90 new file mode 100644 index 0000000000..8eb5b7a181 --- /dev/null +++ b/src/external/esmf_time_f90/ESMF.F90 @@ -0,0 +1,19 @@ +! TBH: This version is for use with the ESMF library embedded in the WRF +! TBH: distribution. +MODULE ESMF + USE ESMF_AlarmMod + USE ESMF_BaseMod + USE ESMF_BaseTimeMod + USE ESMF_CalendarMod + USE ESMF_ClockMod + USE ESMF_FractionMod + USE ESMF_TimeIntervalMod + USE ESMF_TimeMod + USE ESMF_ShrTimeMod + USE ESMF_AlarmClockMod + USE ESMF_Stubs ! add new dummy interfaces and typedefs here as needed + USE MeatMod +#include + INTEGER, PARAMETER :: ESMF_MAX_ALARMS=MAX_ALARMS +! +END MODULE ESMF diff --git a/src/external/esmf_time_f90/ESMF_AlarmClock.F90 b/src/external/esmf_time_f90/ESMF_AlarmClockMod.F90 similarity index 84% rename from src/external/esmf_time_f90/ESMF_AlarmClock.F90 rename to src/external/esmf_time_f90/ESMF_AlarmClockMod.F90 index 30682ca73f..63932f91f7 100644 --- a/src/external/esmf_time_f90/ESMF_AlarmClock.F90 +++ b/src/external/esmf_time_f90/ESMF_AlarmClockMod.F90 @@ -1,3 +1,4 @@ +! $Id$ ! ! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -5,7 +6,7 @@ ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. +! Licensed under the GPL. ! !============================================================================== ! @@ -14,7 +15,7 @@ module ESMF_AlarmClockMod ! !============================================================================== ! -! This file contains the AlarmCreate method. +! This file contains the AlarmCreae method. ! !------------------------------------------------------------------------------ ! INCLUDES @@ -54,6 +55,11 @@ module ESMF_AlarmClockMod ! !PUBLIC MEMBER FUNCTIONS: public ESMF_AlarmCreate +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + !============================================================================== contains @@ -62,13 +68,14 @@ module ESMF_AlarmClockMod ! Create ESMF_Alarm using ESMF 2.1.0+ semantics - FUNCTION ESMF_AlarmCreate( clock, RingTime, RingInterval, & + FUNCTION ESMF_AlarmCreate( name, clock, RingTime, RingInterval, & StopTime, Enabled, rc ) ! return value type(ESMF_Alarm) :: ESMF_AlarmCreate ! !ARGUMENTS: - type(ESMF_Clock), intent(inout), optional :: clock + character(len=*), intent(in) :: name + type(ESMF_Clock), intent(inout) :: clock type(ESMF_Time), intent(in), optional :: RingTime type(ESMF_TimeInterval), intent(in), optional :: RingInterval type(ESMF_Time), intent(in), optional :: StopTime @@ -79,14 +86,13 @@ FUNCTION ESMF_AlarmCreate( clock, RingTime, RingInterval, & ! TBH: ignore allocate errors, for now ALLOCATE( alarmtmp%alarmint ) CALL ESMF_AlarmSet( alarmtmp, & + name=name, & RingTime=RingTime, & RingInterval=RingInterval, & StopTime=StopTime, & Enabled=Enabled, & rc=rc ) - IF ( PRESENT ( clock ) ) THEN - CALL ESMF_ClockAddAlarm( clock, alarmtmp, rc ) - ENDIF + CALL ESMF_ClockAddAlarm( clock, alarmtmp, rc ) ESMF_AlarmCreate = alarmtmp END FUNCTION ESMF_AlarmCreate diff --git a/src/external/esmf_time_f90/ESMF_Alarm.F90 b/src/external/esmf_time_f90/ESMF_AlarmMod.F90 similarity index 86% rename from src/external/esmf_time_f90/ESMF_Alarm.F90 rename to src/external/esmf_time_f90/ESMF_AlarmMod.F90 index 1015093cd1..67400ae7e6 100644 --- a/src/external/esmf_time_f90/ESMF_Alarm.F90 +++ b/src/external/esmf_time_f90/ESMF_AlarmMod.F90 @@ -1,3 +1,4 @@ +! $Id$ ! ! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -5,7 +6,7 @@ ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. +! Licensed under the GPL. ! !============================================================================== ! @@ -40,9 +41,8 @@ module ESMF_AlarmMod use ESMF_BaseMod ! associated derived types - use ESMF_TimeIntervalMod, only : ESMF_TimeInterval, & - ESMF_TimeIntervalAbsValue - use ESMF_TimeMod, only : ESMF_Time + use ESMF_TimeIntervalMod + use ESMF_TimeMod implicit none @@ -57,6 +57,7 @@ module ESMF_AlarmMod ! internals for ESMF_Alarm type ESMF_AlarmInt + character(len=256) :: name = " " type(ESMF_TimeInterval) :: RingInterval type(ESMF_Time) :: RingTime type(ESMF_Time) :: PrevRingTime @@ -76,7 +77,7 @@ module ESMF_AlarmMod ! NOTE: DO NOT ADD NON-POINTER STATE TO THIS DATA TYPE. It emulates ESMF ! shallow-copy-masquerading-as-reference-copy insanity. type ESMF_Alarm - type(ESMF_AlarmInt), pointer :: alarmint + type(ESMF_AlarmInt), pointer :: alarmint => null() end type !------------------------------------------------------------------------------ @@ -93,8 +94,8 @@ module ESMF_AlarmMod ! public ESMF_AlarmSetRingInterval ! public ESMF_AlarmGetRingTime ! public ESMF_AlarmSetRingTime - public ESMF_AlarmGetPrevRingTime - public ESMF_AlarmSetPrevRingTime +! public ESMF_AlarmGetPrevRingTime +! public ESMF_AlarmSetPrevRingTime ! public ESMF_AlarmGetStopTime ! public ESMF_AlarmSetStopTime public ESMF_AlarmEnable @@ -116,6 +117,11 @@ module ESMF_AlarmMod private ESMF_AlarmEQ !EOPI +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + !============================================================================== ! ! INTERFACE BLOCKS @@ -151,12 +157,13 @@ module ESMF_AlarmMod ! !IROUTINE: ESMF_AlarmSet - Initializes an alarm ! !INTERFACE: - subroutine ESMF_AlarmSet(alarm, RingTime, RingInterval, PrevRingTime, & + subroutine ESMF_AlarmSet(alarm, name, RingTime, RingInterval, & StopTime, Enabled, rc) ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm ! really INTENT(OUT) - type(ESMF_Time), intent(in), optional :: RingTime, PrevRingTime + type(ESMF_Alarm), intent(inout) :: alarm + character(len=*), intent(in), optional :: name + type(ESMF_Time), intent(in), optional :: RingTime type(ESMF_TimeInterval), intent(in), optional :: RingInterval type(ESMF_Time), intent(in), optional :: StopTime logical, intent(in), optional :: Enabled @@ -188,15 +195,13 @@ subroutine ESMF_AlarmSet(alarm, RingTime, RingInterval, PrevRingTime, & alarm%alarmint%RingTimeSet = .FALSE. alarm%alarmint%RingIntervalSet = .FALSE. alarm%alarmint%StopTimeSet = .FALSE. + IF ( PRESENT( name ) ) THEN + alarm%alarmint%name = name + END IF IF ( PRESENT( RingInterval ) ) THEN - ! force RingInterval to be positive - alarm%alarmint%RingInterval = & - ESMF_TimeIntervalAbsValue( RingInterval ) + alarm%alarmint%RingInterval = RingInterval alarm%alarmint%RingIntervalSet = .TRUE. ENDIF - IF ( PRESENT( PrevRingTime ) ) THEN - alarm%alarmint%PrevRingTime = PrevRingTime - ENDIF IF ( PRESENT( RingTime ) ) THEN alarm%alarmint%RingTime = RingTime alarm%alarmint%RingTimeSet = .TRUE. @@ -263,8 +268,16 @@ subroutine ESMF_AlarmGetRingInterval(alarm, RingInterval, rc) ! !REQUIREMENTS: ! TMG4.7 !EOP - RingInterval = alarm%alarmint%RingInterval - + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%RingIntervalSet )THEN + RingInterval= alarm%alarmint%RingInterval + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + END IF + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF end subroutine ESMF_AlarmGetRingInterval !------------------------------------------------------------------------------ @@ -326,7 +339,29 @@ subroutine ESMF_AlarmGetRingTime(alarm, RingTime, rc) ! !REQUIREMENTS: ! TMG4.7, TMG4.8 !EOP - CALL wrf_error_fatal( 'ESMF_AlarmGetRingTime not supported' ) + type(ESMF_Time) :: PrevRingTime + type(ESMF_TimeInterval) :: RingInterval + integer :: ierr + + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%RingIntervalSet )THEN + PrevRingTime = alarm%alarmint%PrevRingTime + call ESMF_AlarmGetRingInterval( alarm, RingInterval, ierr) + IF ( PRESENT( rc ) .AND. (ierr /= ESMF_SUCCESS) )THEN + rc = ierr + return + END IF + RingTime = PrevRingTime + RingInterval + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE IF ( alarm%alarmint%RingTimeSet )THEN + RingTime = alarm%alarmint%RingTime + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + END IF + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF end subroutine ESMF_AlarmGetRingTime !------------------------------------------------------------------------------ @@ -365,10 +400,12 @@ end subroutine ESMF_AlarmSetRingTime ! !IROUTINE: ESMF_AlarmGet - Get an alarm's parameters -- compatibility with ESMF 2.0.1 ! ! !INTERFACE: - subroutine ESMF_AlarmGet(alarm, PrevRingTime, RingInterval, rc) + subroutine ESMF_AlarmGet(alarm, name, RingTime, PrevRingTime, RingInterval, rc) ! !ARGUMENTS: type(ESMF_Alarm), intent(in) :: alarm + character(len=*), intent(out), optional :: name + type(ESMF_Time), intent(out), optional :: RingTime type(ESMF_Time), intent(out), optional :: PrevRingTime type(ESMF_TimeInterval), intent(out), optional :: RingInterval integer, intent(out), optional :: rc @@ -380,7 +417,11 @@ subroutine ESMF_AlarmGet(alarm, PrevRingTime, RingInterval, rc) ! The arguments are: ! \begin{description} ! \item[alarm] -! The object instance to get the previous ring time +! The object instance to get +! \item[ringTime] +! The ring time for a one-shot alarm or the next repeating alarm. +! \item[ringInterval] +! The ring interval for repeating (interval) alarms. ! \item[PrevRingTime] ! The {\tt ESMF\_Alarm}'s previous ring time ! \item[{[rc]}] @@ -393,9 +434,19 @@ subroutine ESMF_AlarmGet(alarm, PrevRingTime, RingInterval, rc) ierr = ESMF_SUCCESS + IF ( PRESENT(name) ) THEN + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + name = alarm%alarmint%name + ELSE + ierr = ESMF_FAILURE + END IF + ENDIF IF ( PRESENT(PrevRingTime) ) THEN CALL ESMF_AlarmGetPrevRingTime(alarm, PrevRingTime, rc=ierr) ENDIF + IF ( PRESENT(RingTime) ) THEN + CALL ESMF_AlarmGetRingTime(alarm, RingTime, rc=ierr) + ENDIF IF ( PRESENT(RingInterval) ) THEN CALL ESMF_AlarmGetRingInterval(alarm, RingInterval, rc=ierr) ENDIF @@ -454,13 +505,23 @@ subroutine ESMF_AlarmSetPrevRingTime(alarm, PrevRingTime, rc) type(ESMF_Time), intent(in) :: PrevRingTime integer, intent(out), optional :: rc - IF ( ASSOCIATED( alarm%alarmint ) ) THEN - alarm%alarmint%PrevRingTime = PrevRingTime - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS - ELSE - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - ENDIF - +! !DESCRIPTION: +! Set an {\tt ESMF\_Alarm}'s previous ring time +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to set the previous ring time +! \item[PrevRingTime] +! The {\tt ESMF\_Alarm}'s previous ring time to set +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.7, TMG4.8 +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmSetPrevRingTime not supported' ) end subroutine ESMF_AlarmSetPrevRingTime !------------------------------------------------------------------------------ @@ -533,7 +594,7 @@ end subroutine ESMF_AlarmSetStopTime subroutine ESMF_AlarmEnable(alarm, rc) ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm ! really INTENT(OUT) + type(ESMF_Alarm), intent(inout) :: alarm integer, intent(out), optional :: rc ! !DESCRIPTION: @@ -566,7 +627,7 @@ end subroutine ESMF_AlarmEnable subroutine ESMF_AlarmDisable(alarm, rc) ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm ! really INTENT(OUT) + type(ESMF_Alarm), intent(inout) :: alarm integer, intent(out), optional :: rc ! !DESCRIPTION: @@ -600,7 +661,7 @@ end subroutine ESMF_AlarmDisable subroutine ESMF_AlarmRingerOn(alarm, rc) ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm ! really INTENT(OUT) + type(ESMF_Alarm), intent(inout) :: alarm integer, intent(out), optional :: rc ! !DESCRIPTION: @@ -639,7 +700,7 @@ end subroutine ESMF_AlarmRingerOn subroutine ESMF_AlarmRingerOff(alarm, rc) ! !ARGUMENTS: - type(ESMF_Alarm), intent(inout) :: alarm ! really INTENT(OUT) + type(ESMF_Alarm), intent(inout) :: alarm integer, intent(out), optional :: rc ! !DESCRIPTION: @@ -945,7 +1006,35 @@ subroutine ESMF_AlarmPrint(alarm, opts, rc) ! !REQUIREMENTS: ! TMGn.n.n !EOP - CALL wrf_error_fatal( 'ESMF_AlarmPrint not supported' ) + integer :: ierr + type(ESMF_Time) :: ringtime + type(ESMF_Time) :: prevringtime + type(ESMF_TimeInterval) :: ringinterval + character(len=256) :: name + + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%RingTimeSet )THEN + call ESMF_AlarmGet( alarm, name=name, ringtime=ringtime, & + prevringtime=prevringtime, rc=ierr ) + IF ( PRESENT(rc) .AND. (ierr /= ESMF_SUCCESS) )THEN + rc = ierr + END IF + print *, 'Alarm name: ', trim(name) + print *, 'Next ring time' + call ESMF_TimePrint( ringtime ) + print *, 'Previous ring time' + call ESMF_TimePrint( prevringtime ) + END IF + IF ( alarm%alarmint%RingIntervalSet )THEN + call ESMF_AlarmGet( alarm, ringinterval=ringinterval, rc=ierr ) + IF ( PRESENT(rc) .AND. (ierr /= ESMF_SUCCESS) )THEN + rc = ierr + END IF + print *, 'Ring Interval' + call ESMF_TimeIntervalPrint( ringinterval ) + END IF + END IF + end subroutine ESMF_AlarmPrint !------------------------------------------------------------------------------ diff --git a/src/external/esmf_time_f90/ESMF_Base.F90 b/src/external/esmf_time_f90/ESMF_BaseMod.F90 similarity index 98% rename from src/external/esmf_time_f90/ESMF_Base.F90 rename to src/external/esmf_time_f90/ESMF_BaseMod.F90 index 31068fb0d7..ad867122dd 100644 --- a/src/external/esmf_time_f90/ESMF_Base.F90 +++ b/src/external/esmf_time_f90/ESMF_BaseMod.F90 @@ -1,3 +1,4 @@ +! $Id$ ! ! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -5,7 +6,7 @@ ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. +! Licensed under the GPL. ! ! ESMF Base Module ! @@ -48,10 +49,10 @@ module ESMF_BaseMod ESMF_MAXGRIDDIM=2 integer, parameter :: ESMF_MAJOR_VERSION = 2 - integer, parameter :: ESMF_MINOR_VERSION = 1 - integer, parameter :: ESMF_REVISION = 1 + integer, parameter :: ESMF_MINOR_VERSION = 2 + integer, parameter :: ESMF_REVISION = 3 integer, parameter :: ESMF_PATCHLEVEL = 0 - character(32), parameter :: ESMF_VERSION_STRING = "2.1.1" + character(32), parameter :: ESMF_VERSION_STRING = "2.2.3" !------------------------------------------------------------------------------ ! @@ -280,6 +281,12 @@ module ESMF_BaseMod ! !EOP +!------------------------------------------------------------------------------ +! leave the following line as-is; it will insert the cvs ident string +! into the object file for tracking purposes. + character(*), parameter, private :: version = & + '$Id$' +!------------------------------------------------------------------------------ !------------------------------------------------------------------------------ ! overload .eq. & .ne. with additional derived types so you can compare diff --git a/src/external/esmf_time_f90/ESMF_BaseTime.F90 b/src/external/esmf_time_f90/ESMF_BaseTimeMod.F90 similarity index 70% rename from src/external/esmf_time_f90/ESMF_BaseTime.F90 rename to src/external/esmf_time_f90/ESMF_BaseTimeMod.F90 index 85c16fcc32..6eb4573afe 100644 --- a/src/external/esmf_time_f90/ESMF_BaseTime.F90 +++ b/src/external/esmf_time_f90/ESMF_BaseTimeMod.F90 @@ -1,3 +1,4 @@ +! $Id$ ! ! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -5,7 +6,7 @@ ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. +! Licensed under the GPL. ! !============================================================================== ! @@ -62,6 +63,8 @@ module ESMF_BaseTimeMod ! !PUBLIC MEMBER FUNCTIONS: ! ! overloaded operators + public seccmp + public normalize_basetime public operator(+) private ESMF_BaseTimeSum public operator(-) @@ -122,6 +125,49 @@ module ESMF_BaseTimeMod !============================================================================== +SUBROUTINE normalize_basetime( basetime ) + ! Factor so abs(Sn) < Sd and ensure that signs of S and Sn match. + ! Also, enforce consistency. + ! YR and MM fields are ignored. + IMPLICIT NONE + TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime + + !PRINT *,'DEBUG: BEGIN normalize_basetime()' + ! Consistency check... + IF ( basetime%Sd < 0 ) THEN + CALL wrf_error_fatal( & + 'normalize_basetime: denominator of seconds cannot be negative' ) + ENDIF + IF ( ( basetime%Sd == 0 ) .AND. ( basetime%Sn .NE. 0 ) ) THEN + CALL wrf_error_fatal( & + 'normalize_basetime: denominator of seconds cannot be zero when numerator is non-zero' ) + ENDIF + ! factor so abs(Sn) < Sd + IF ( basetime%Sd > 0 ) THEN + IF ( ABS( basetime%Sn ) .GE. basetime%Sd ) THEN + !PRINT *,'DEBUG: normalize_basetime() A1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + basetime%S = basetime%S + ( basetime%Sn / basetime%Sd ) + basetime%Sn = mod( basetime%Sn, basetime%Sd ) + !PRINT *,'DEBUG: normalize_basetime() A2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + ENDIF + ! change sign of Sn if it does not match S + IF ( ( basetime%S > 0 ) .AND. ( basetime%Sn < 0 ) ) THEN + !PRINT *,'DEBUG: normalize_basetime() B1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + basetime%S = basetime%S - 1_ESMF_KIND_I8 + basetime%Sn = basetime%Sn + basetime%Sd + !PRINT *,'DEBUG: normalize_basetime() B2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + ENDIF + IF ( ( basetime%S < 0 ) .AND. ( basetime%Sn > 0 ) ) THEN + !PRINT *,'DEBUG: normalize_basetime() C1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + basetime%S = basetime%S + 1_ESMF_KIND_I8 + basetime%Sn = basetime%Sn - basetime%Sd + !PRINT *,'DEBUG: normalize_basetime() C2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + ENDIF + ENDIF + !PRINT *,'DEBUG: END normalize_basetime()' +END SUBROUTINE normalize_basetime + +!============================================================================== ! Add two basetimes FUNCTION ESMF_BaseTimeSum( basetime1, basetime2 ) @@ -314,5 +360,102 @@ FUNCTION ESMF_BaseTimeGE( basetime1, basetime2 ) ESMF_BaseTimeGE = ( retval .GE. 0 ) END FUNCTION ESMF_BaseTimeGE +!============================================================================== + +SUBROUTINE compute_lcd( e1, e2, lcd ) + IMPLICIT NONE + INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2 + INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd + INTEGER, PARAMETER :: nprimes = 9 + INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) + INTEGER i + INTEGER(ESMF_KIND_I8) d1, d2, p + + d1 = e1 ; d2 = e2 + IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF + IF ( d1 .EQ. 0 ) d1 = d2 + IF ( d2 .EQ. 0 ) d2 = d1 + IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF + lcd = d1 * d2 + DO i = 1, nprimes + p = primes(i) + DO WHILE (lcd/p .NE. 0 .AND. & + mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0) + lcd = lcd / p + END DO + ENDDO +END SUBROUTINE compute_lcd + +!============================================================================== + +SUBROUTINE simplify( ni, di, no, do ) + IMPLICIT NONE + INTEGER(ESMF_KIND_I8), INTENT(IN) :: ni, di + INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do + INTEGER, PARAMETER :: nprimes = 9 + INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) + INTEGER(ESMF_KIND_I8) :: pr, d, n + INTEGER :: np + LOGICAL keepgoing + IF ( ni .EQ. 0 ) THEN + do = 1 + no = 0 + RETURN + ENDIF + IF ( mod( di , ni ) .EQ. 0 ) THEN + do = di / ni + no = 1 + RETURN + ENDIF + d = di + n = ni + DO np = 1, nprimes + pr = primes(np) + keepgoing = .TRUE. + DO WHILE ( keepgoing ) + keepgoing = .FALSE. + IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN + d = d / pr + n = n / pr + keepgoing = .TRUE. + ENDIF + ENDDO + ENDDO + do = d + no = n + RETURN +END SUBROUTINE simplify + +!============================================================================== + +! spaceship operator for seconds + Sn/Sd +SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval ) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: retval +! +! !ARGUMENTS: + INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1 + INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2 +! local + INTEGER(ESMF_KIND_I8) :: lcd, n1, n2 + + n1 = Sn1 + n2 = Sn2 + if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then + CALL compute_lcd( Sd1, Sd2, lcd ) + if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 ) + if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 ) + endif + + if ( S1 .GT. S2 ) retval = 1 + if ( S1 .LT. S2 ) retval = -1 + IF ( S1 .EQ. S2 ) THEN + IF (n1 .GT. n2) retval = 1 + IF (n1 .LT. n2) retval = -1 + IF (n1 .EQ. n2) retval = 0 + ENDIF +END SUBROUTINE seccmp + +!============================================================================== end module ESMF_BaseTimeMod diff --git a/src/external/esmf_time_f90/ESMF_Calendar.F90 b/src/external/esmf_time_f90/ESMF_Calendar.F90 deleted file mode 100644 index a15c6b03de..0000000000 --- a/src/external/esmf_time_f90/ESMF_Calendar.F90 +++ /dev/null @@ -1,314 +0,0 @@ -! -! Earth System Modeling Framework -! Copyright 2002-2003, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, -! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. -! -!============================================================================== -! -! ESMF Calendar Module - module ESMF_CalendarMod -! -!============================================================================== -! -! This file contains the Calendar class definition and all Calendar class -! methods. -! -!------------------------------------------------------------------------------ -! INCLUDES -#include - -!============================================================================== -!BOPI -! !MODULE: ESMF_CalendarMod -! -! !DESCRIPTION: -! Part of Time Manager F90 API wrapper of C++ implemenation -! -! Defines F90 wrapper entry points for corresponding -! C++ class { \tt ESMC\_Calendar} implementation -! -! See {\tt ../include/ESMC\_Calendar.h} for complete description -! -!------------------------------------------------------------------------------ -! !USES: - ! inherit from ESMF base class - use ESMF_BaseMod - - ! inherit from base time class - use ESMF_BaseTimeMod - - implicit none -! -!------------------------------------------------------------------------------ -! !PRIVATE TYPES: - private -!------------------------------------------------------------------------------ - - - - INTEGER, PARAMETER :: MONTHS_PER_YEAR = 12 - - INTEGER, PARAMETER :: daysPerMonthNoLeap(MONTHS_PER_YEAR) & - = (/31,28,31,30,31,30,31,31,30,31,30,31/) - INTEGER, PARAMETER :: daysPerMonthLeap(MONTHS_PER_YEAR) & - = (/31,29,31,30,31,30,31,31,30,31,30,31/) - INTEGER, PARAMETER :: daysPerMonth360(MONTHS_PER_YEAR) & - = (/30,30,30,30,30,30,30,30,30,30,30,30/) - - INTEGER, DIMENSION(MONTHS_PER_YEAR) :: mday - INTEGER, DIMENSION(MONTHS_PER_YEAR) :: mdayleap - - INTEGER, DIMENSION(:), POINTER :: daym - INTEGER, DIMENSION(:), POINTER :: daymleap - - INTEGER :: mdaycum(0:MONTHS_PER_YEAR) - INTEGER :: mdayleapcum(0:MONTHS_PER_YEAR) - - TYPE(ESMF_BaseTime), TARGET :: monthbdys(0:MONTHS_PER_YEAR) - TYPE(ESMF_BaseTime), TARGET :: monthbdysleap(0:MONTHS_PER_YEAR) - - -!------------------------------------------------------------------------------ -! ! ESMF_CalendarType -! -! ! F90 "enum" type to match C++ ESMC_CalendarType enum - - type ESMF_CalendarType - integer :: caltype - end type - - type(ESMF_CalendarType), parameter :: & - ESMF_CAL_GREGORIAN = ESMF_CalendarType(1), & - ESMF_CAL_JULIAN = ESMF_CalendarType(2), & - ! like Gregorian, except Feb always has 28 days - ESMF_CAL_NOLEAP = ESMF_CalendarType(3), & - ! 12 months, 30 days each - ESMF_CAL_360DAY = ESMF_CalendarType(4), & - ! user defined - ESMF_CAL_GENERIC = ESMF_CalendarType(5), & - ! track base time seconds only - ESMF_CAL_NOCALENDAR = ESMF_CalendarType(6) - -!------------------------------------------------------------------------------ -! ! ESMF_Calendar -! -! ! F90 class type to match C++ Calendar class in size only; -! ! all dereferencing within class is performed by C++ implementation -! -!------------------------------------------------------------------------------ -! -! ! ESMF_DaysPerYear -! - type ESMF_DaysPerYear - private - integer :: D ! whole days per year -! Fractional days-per-year are not yet used in this implementation. -! integer :: Dn ! fractional days per year numerator -! integer :: Dd ! fractional days per year denominator - end type ! e.g. for Venus, D=0, Dn=926, Dd=1000 -! -!------------------------------------------------------------------------------ -! ! ESMF_Calendar -! -! - type ESMF_Calendar - private - type(ESMF_CalendarType) :: Type -! TBH: When NO_DT_COMPONENT_INIT is set, code that uses F95 compile-time -! TBH: initialization of components of derived types is not included. -! TBH: Some older compilers, like PGI 5.x do not support this F95 feature. -#ifdef NO_DT_COMPONENT_INIT - logical :: Set -#else - logical :: Set = .false. -#endif - integer, dimension(MONTHS_PER_YEAR) :: DaysPerMonth - integer :: SecondsPerDay - integer :: SecondsPerYear - type(ESMF_DaysPerYear) :: DaysPerYear - end type - -!------------------------------------------------------------------------------ -! !PUBLIC DATA: - TYPE(ESMF_Calendar), public, save, pointer :: defaultCal ! Default Calendar - - -! -!------------------------------------------------------------------------------ -! !PUBLIC TYPES: - public MONTHS_PER_YEAR - public mday - public mdayleap - public monthbdys - public monthbdysleap - public daym - public daymleap - public mdaycum - public mdayleapcum - public ESMF_CalendarType - public ESMF_CAL_GREGORIAN, ESMF_CAL_NOLEAP, & - ESMF_CAL_360DAY, ESMF_CAL_NOCALENDAR -! public ESMF_CAL_JULIAN -! public ESMF_CAL_GENERIC - public ESMF_Calendar - -!------------------------------------------------------------------------------ -! -! !PUBLIC MEMBER FUNCTIONS: - public ESMF_CalendarCreate - public ESMF_CalendarDestroy - public ESMF_GetCalendarType - - -! Required inherited and overridden ESMF_Base class methods - - public ESMF_CalendarInitialized ! Only in this implementation, intended - ! to be private within ESMF methods -!EOPI - -!============================================================================== - - contains - - -!============================================================================== - - - type(ESMF_CalendarType) function ESMF_GetCalendarType() - ESMF_GetCalendarType = defaultCal % Type - end function ESMF_GetCalendarType - - -!============================================================================== -!BOP -! !IROUTINE: ESMF_CalendarCreate - Create a new ESMF Calendar of built-in type - -! !INTERFACE: - ! Private name; call using ESMF_CalendarCreate() - function ESMF_CalendarCreate(name, calendartype, rc) - -! !RETURN VALUE: - type(ESMF_Calendar) :: ESMF_CalendarCreate - -! !ARGUMENTS: - character (len=*), intent(in), optional :: name - type(ESMF_CalendarType), intent(in) :: calendartype - integer, intent(out), optional :: rc - -! !DESCRIPTION: -! Creates and sets a {\tt calendar} to the given built-in -! {\tt ESMF\_CalendarType}. -! -! This is a private method; invoke via the public overloaded entry point -! {\tt ESMF\_CalendarCreate()}. -! -! The arguments are: -! \begin{description} -! \item[{[name]}] -! The name for the newly created calendar. If not specified, a -! default unique name will be generated: "CalendarNNN" where NNN -! is a unique sequence number from 001 to 999. -! \item[calendartype] -! The built-in {\tt ESMF\_CalendarType}. Valid values are: -! {\tt ESMF\_CAL\_360DAY}, {\tt ESMF\_CAL\_GREGORIAN}, -! {\tt ESMF\_CAL\_JULIANDAY}, {\tt ESMF\_CAL\_NOCALENDAR}, and -! {\tt ESMF\_CAL\_NOLEAP}. -! See the "Time Manager Reference" document for a description of -! each calendar type. -! \item[{[rc]}] -! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. -! \end{description} -! -!EOP -! !REQUIREMENTS: -! TMGn.n.n - type(ESMF_DaysPerYear) :: dayspy - - if ( present(rc) ) rc = ESMF_FAILURE - - if ( calendartype % caltype == ESMF_CAL_GREGORIAN % caltype ) then - ESMF_CalendarCreate % Type = ESMF_CAL_GREGORIAN - mday = daysPerMonthNoLeap - mdayleap = daysPerMonthLeap - allocate(daym(365)) - allocate(daymleap(366)) - else if ( calendartype % caltype == ESMF_CAL_NOLEAP % caltype ) then - ESMF_CalendarCreate % Type = ESMF_CAL_NOLEAP - mday = daysPerMonthNoLeap - mdayleap = daysPerMonthNoLeap - allocate(daym(365)) - allocate(daymleap(365)) - else if ( calendartype % caltype == ESMF_CAL_360DAY % caltype ) then - ESMF_CalendarCreate % Type = ESMF_CAL_360DAY - mday = daysPerMonth360 - mdayleap = daysPerMonth360 - allocate(daym(360)) - allocate(daymleap(360)) - else - write(6,*) 'Not a valid calendar type for this implementation' - write(6,*) 'The current implementation only supports ESMF_CAL_NOLEAP, ESMF_CAL_GREGORIAN, ESMF_CAL_360DAY' - return - end if - - ESMF_CalendarCreate % Set = .true. - ESMF_CalendarCreate % DaysPerMonth(:) = mday(:) - ESMF_CalendarCreate % SecondsPerDay = SECONDS_PER_DAY - -!TBH: TODO: Replace DaysPerYear and SecondsPerYear with methods -!TBH: TODO: since they only make sense for the NO_LEAP calendar! - dayspy % D = size(daym) - ESMF_CalendarCreate % DaysPerYear = dayspy - ESMF_CalendarCreate % SecondsPerYear = ESMF_CalendarCreate % SecondsPerDay * dayspy % D - - if ( present(rc) ) rc = ESMF_SUCCESS - - end function ESMF_CalendarCreate - - - subroutine ESMF_CalendarDestroy(rc) - - integer, intent(out), optional :: rc - - if ( present(rc) ) rc = ESMF_FAILURE - - deallocate(daym) - deallocate(daymleap) - - if ( present(rc) ) rc = ESMF_SUCCESS - - end subroutine ESMF_CalendarDestroy - - - -!============================================================================== -!BOP -! !IROUTINE: ESMF_CalendarInitialized - check if calendar was created - -! !INTERFACE: - function ESMF_CalendarInitialized(calendar) - -! !RETURN VALUE: - logical ESMF_CalendarInitialized - -! !ARGUMENTS: - type(ESMF_Calendar), intent(in) :: calendar - -! !DESCRIPTION: -!EOP -! !REQUIREMENTS: -! TMGn.n.n -! Note that return value from this function will be bogus for older compilers -! that do not support compile-time initialization of data members of Fortran -! derived data types. For example, PGI 5.x compilers do not support this F95 -! feature. At the moment, the call to this fuction is #ifdefd out when the -! leap-year calendar is used so this is not an issue for WRF (see -! NO_DT_COMPONENT_INIT). - ESMF_CalendarInitialized = calendar%set - - end function ESMF_CalendarInitialized - - end module ESMF_CalendarMod diff --git a/src/external/esmf_time_f90/ESMF_CalendarMod.F90 b/src/external/esmf_time_f90/ESMF_CalendarMod.F90 new file mode 100644 index 0000000000..dc874bdb9c --- /dev/null +++ b/src/external/esmf_time_f90/ESMF_CalendarMod.F90 @@ -0,0 +1,502 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +!============================================================================== +! +! ESMF Calendar Module + module ESMF_CalendarMod +! +!============================================================================== +! +! This file contains the Calendar class definition and all Calendar class +! methods. +! +!------------------------------------------------------------------------------ +! INCLUDES +#include + +!============================================================================== +!BOPI +! !MODULE: ESMF_CalendarMod +! +! !DESCRIPTION: +! Part of Time Manager F90 API wrapper of C++ implemenation +! +! Defines F90 wrapper entry points for corresponding +! C++ class { \tt ESMC\_Calendar} implementation +! +! See {\tt ../include/ESMC\_Calendar.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit from ESMF base class + use ESMF_BaseMod + + ! inherit from base time class + use ESMF_BaseTimeMod + + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ + + INTEGER, PARAMETER :: mday(MONTHS_PER_YEAR) & + = (/31,28,31,30,31,30,31,31,30,31,30,31/) + INTEGER, PARAMETER :: mdayleap(MONTHS_PER_YEAR) & + = (/31,29,31,30,31,30,31,31,30,31,30,31/) + INTEGER, DIMENSION(365) :: daym + INTEGER, DIMENSION(366) :: daymleap + INTEGER :: mdaycum(0:MONTHS_PER_YEAR) + INTEGER :: mdayleapcum(0:MONTHS_PER_YEAR) + TYPE(ESMF_BaseTime), TARGET :: monthbdys(0:MONTHS_PER_YEAR) + TYPE(ESMF_BaseTime), TARGET :: monthbdysleap(0:MONTHS_PER_YEAR) + TYPE(ESMF_BaseTime), TARGET :: monthedys(0:MONTHS_PER_YEAR) + TYPE(ESMF_BaseTime), TARGET :: monthedysleap(0:MONTHS_PER_YEAR) + + +!------------------------------------------------------------------------------ +! ! ESMF_CalKind_Flag +! +! ! F90 "enum" type to match C++ ESMC_CalKind_Flag enum + + type ESMF_CalKind_Flag + integer :: caltype + end type + + type(ESMF_CalKind_Flag), parameter :: & + ESMF_CALKIND_GREGORIAN = ESMF_CalKind_Flag(1), & + ESMF_CALKIND_NOLEAP = ESMF_CalKind_Flag(2) + +! type(ESMF_CalKind_Flag), parameter :: & +! ESMF_CALKIND_GREGORIAN = ESMF_CalKind_Flag(1), & +! ESMF_CALKIND_JULIAN = ESMF_CalKind_Flag(2), & +! ! like Gregorian, except Feb always has 28 days +! ESMF_CALKIND_NOLEAP = ESMF_CalKind_Flag(3), & +! ! 12 months, 30 days each +! ESMF_CALKIND_360DAY = ESMF_CalKind_Flag(4), & +! ! user defined +! ESMF_CALKIND_GENERIC = ESMF_CalKind_Flag(5), & +! ! track base time seconds only +! ESMF_CALKIND_NOCALENDAR = ESMF_CalKind_Flag(6) + +!------------------------------------------------------------------------------ +! ! ESMF_Calendar +! +! ! F90 class type to match C++ Calendar class in size only; +! ! all dereferencing within class is performed by C++ implementation +! +!------------------------------------------------------------------------------ +! +! ! ESMF_DaysPerYear +! + type ESMF_DaysPerYear + integer :: D = 0 ! whole days per year + integer :: Dn = 0 ! fractional days per year numerator + integer :: Dd = 1 ! fractional days per year denominator + end type ! e.g. for Venus, D=0, Dn=926, Dd=1000 +! +!------------------------------------------------------------------------------ +! ! ESMF_Calendar +! +! + type ESMF_Calendar + type(ESMF_CalKind_Flag) :: Type + logical :: Set = .false. + integer, dimension(MONTHS_PER_YEAR) :: DaysPerMonth = 0 + integer :: SecondsPerDay = 0 + integer :: SecondsPerYear = 0 + type(ESMF_DaysPerYear) :: DaysPerYear + end type +!------------------------------------------------------------------------------ +! !PUBLIC DATA: added by Juanxiong He, in order to breakthe cycle call between +! ESMF_Stubs and ESMF_Time + TYPE(ESMF_Calendar), public, save, pointer :: defaultCal ! Default Calendar + TYPE(ESMF_Calendar), public, save, pointer :: gregorianCal ! gregorian Calendar + TYPE(ESMF_Calendar), public, save, pointer :: noleapCal ! noleap Calendar + +! +!------------------------------------------------------------------------------ +! !PUBLIC TYPES: + public initdaym +! public mday +! public mdayleap +! public monthbdys +! public monthbdysleap +! public monthedys +! public monthedysleap +! public daym +! public daymleap +! public mdaycum +! public mdayleapcum + public ndaysinmonth + public nsecondsinmonth + public ndaysinyear + public nsecondsinyear + public nmonthinyearsec + public ndayinyearsec + public nsecondsinyearmonth + public isleap + public ESMF_CalKind_Flag + public ESMF_CALKIND_GREGORIAN, ESMF_CALKIND_NOLEAP +! ESMF_CALKIND_360DAY, ESMF_CALKIND_NOCALENDAR +! public ESMF_CAL_JULIAN +! public ESMF_CAL_GENERIC + public ESMF_Calendar + public ESMF_DaysPerYear + +!------------------------------------------------------------------------------ +! +! !PUBLIC MEMBER FUNCTIONS: + public ESMF_CalendarCreate + +! Required inherited and overridden ESMF_Base class methods + + public ESMF_CalendarInitialized ! Only in this implementation, intended + ! to be private within ESMF methods +!EOPI + +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + +!============================================================================== + + contains + + +!============================================================================== +!BOP +! !IROUTINE: ESMF_CalendarCreate - Create a new ESMF Calendar of built-in type + +! !INTERFACE: + ! Private name; call using ESMF_CalendarCreate() + function ESMF_CalendarCreate(name, calkindflag, rc) + +! !RETURN VALUE: + type(ESMF_Calendar) :: ESMF_CalendarCreate + +! !ARGUMENTS: + character (len=*), intent(in), optional :: name + type(ESMF_CalKind_Flag), intent(in) :: calkindflag + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Creates and sets a {\tt calendar} to the given built-in +! {\tt ESMF\_CalKind_Flag}. +! +! This is a private method; invoke via the public overloaded entry point +! {\tt ESMF\_CalendarCreate()}. +! +! The arguments are: +! \begin{description} +! \item[{[name]}] +! The name for the newly created calendar. If not specified, a +! default unique name will be generated: "CalendarNNN" where NNN +! is a unique sequence number from 001 to 999. +! \item[calkindflag] +! The built-in {\tt ESMF\_CalKind_Flag}. Valid values are: +! {\tt ESMF\_CAL\_360DAY}, {\tt ESMF\_CAL\_GREGORIAN}, +! {\tt ESMF\_CAL\_JULIANDAY}, {\tt ESMF\_CAL\_NOCALENDAR}, and +! {\tt ESMF\_CAL\_NOLEAP}. +! See the "Time Manager Reference" document for a description of +! each calendar type. +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +!EOP +! !REQUIREMENTS: +! TMGn.n.n + type(ESMF_DaysPerYear) :: dayspy + + if ( present(rc) ) rc = ESMF_FAILURE +! Calendar is hard-coded. Use ESMF library if more flexibility is needed. +! write(6,*) 'tcx ESMF_CalendarCreate ',calkindflag%caltype, ESMF_CALKIND_NOLEAP%caltype, ESMF_CALKIND_GREGORIAN%caltype + if ( calkindflag%caltype == ESMF_CALKIND_NOLEAP%caltype ) then +! write(6,*) 'tcx ESMF_CalendarCreate: initialize noleap calendar ' + ESMF_CalendarCreate%Type = ESMF_CALKIND_NOLEAP + elseif ( calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype ) then +! write(6,*) 'tcx ESMF_CalendarCreate: initialize gregorian calendar ' + ESMF_CalendarCreate%Type = ESMF_CALKIND_GREGORIAN + else +! write(6,*) 'tcx ESMF_CalendarCreate: ERROR initialize invalid calendar' + call wrf_error_fatal( "Error:: ESMF_CalendarCreate invalid calendar") + endif + +!$$$ This is a bug on some systems -- need initial value set by compiler at +!$$$ startup. + ESMF_CalendarCreate%Set = .true. + ESMF_CalendarCreate%SecondsPerDay = SECONDS_PER_DAY +! DaysPerYear and SecondsPerYear are incorrect for Gregorian calendars... + dayspy%D = size(daym) + dayspy%Dn = 0 + dayspy%Dd = 1 + ESMF_CalendarCreate%DaysPerYear = dayspy + ESMF_CalendarCreate%SecondsPerYear = ESMF_CalendarCreate%SecondsPerDay & + * dayspy%D + ESMF_CalendarCreate%DaysPerMonth(:) = mday(:) + + if ( present(rc) ) rc = ESMF_SUCCESS + + end function ESMF_CalendarCreate + + +!============================================================================== +!BOP +! !IROUTINE: ESMF_CalendarInitialized - check if calendar was created + +! !INTERFACE: + function ESMF_CalendarInitialized(calendar) + +! !RETURN VALUE: + logical ESMF_CalendarInitialized + +! !ARGUMENTS: + type(ESMF_Calendar), intent(in) :: calendar + +! !DESCRIPTION: +!EOP +! !REQUIREMENTS: +! TMGn.n.n + ESMF_CalendarInitialized = calendar%set + if ( calendar%SecondsPerDay == 0 ) & + ESMF_CalendarInitialized = .false. + + end function ESMF_CalendarInitialized + +!============================================================================== + +SUBROUTINE initdaym + IMPLICIT NONE + INTEGER i,j,m + + m = 1 + mdaycum(0) = 0 +!$$$ push this down into ESMF_BaseTime constructor + monthbdys(0)%S = 0 + monthbdys(0)%Sn = 0 + monthbdys(0)%Sd = 0 + DO i = 1,MONTHS_PER_YEAR + DO j = 1,mday(i) + daym(m) = i + m = m + 1 + ENDDO + mdaycum(i) = mdaycum(i-1) + mday(i) +!$$$ push this down into ESMF_BaseTime constructor + monthbdys(i)%S = SECONDS_PER_DAY * INT( mdaycum(i), ESMF_KIND_I8 ) + monthbdys(i)%Sn = 0 + monthbdys(i)%Sd = 0 + ENDDO + ! End of month seconds, day before the beginning of next month + DO i = 0,MONTHS_PER_YEAR + j = i + 1 + if ( i == MONTHS_PER_YEAR ) j = 0 + monthedys(i) = monthbdys(j) + monthedys(i)%S = monthedys(i)%S - SECONDS_PER_DAY + ENDDO + + m = 1 + mdayleapcum(0) = 0 +!$$$ push this down into ESMF_BaseTime constructor + monthbdysleap(0)%S = 0 + monthbdysleap(0)%Sn = 0 + monthbdysleap(0)%Sd = 0 + DO i = 1,MONTHS_PER_YEAR + DO j = 1,mdayleap(i) + daymleap(m) = i + m = m + 1 + ENDDO + mdayleapcum(i) = mdayleapcum(i-1) + mdayleap(i) +!$$$ push this down into ESMF_BaseTime constructor + monthbdysleap(i)%S = SECONDS_PER_DAY * INT( mdayleapcum(i), ESMF_KIND_I8 ) + monthbdysleap(i)%Sn = 0 + monthbdysleap(i)%Sd = 0 + ENDDO + ! End of month seconds, day before the beginning of next month + DO i = 0,MONTHS_PER_YEAR + j = i + 1 + if ( i == MONTHS_PER_YEAR ) j = 0 + monthedysleap(i) = monthbdysleap(j) + monthedysleap(i)%S = monthedysleap(i)%S - SECONDS_PER_DAY + ENDDO + +END SUBROUTINE initdaym + +!============================================================================== + +integer(esmf_kind_i8) FUNCTION nsecondsinyear ( year, calkindflag ) + ! Compute the number of seconds in the given year + IMPLICIT NONE + INTEGER, INTENT(IN) :: year + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + + nsecondsinyear = SECONDS_PER_DAY * INT( ndaysinyear(year, calkindflag) , ESMF_KIND_I8 ) + +END FUNCTION nsecondsinyear + +!============================================================================== + +integer function ndaysinmonth( year,month,calkindflag) + ! Compute number of days in month for year, month, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year,month + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + ! locals + + IF ( ( MONTH < 1 ) .OR. ( MONTH > MONTHS_PER_YEAR ) ) THEN + CALL wrf_error_fatal( 'ERROR ndaysinmonth: MONTH out of range' ) + ENDIF + + IF ( isleap(year,calkindflag) ) THEN + ndaysinmonth = mdayleap(month) + ELSE + ndaysinmonth = mday(month) + ENDIF + +END function ndaysinmonth +!============================================================================== + +integer(esmf_kind_i8) function nsecondsinmonth( year,month,calkindflag) + ! Compute number of days in month for year, month, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year,month + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + ! locals + + nsecondsinmonth = ndaysinmonth(year,month,calkindflag)*SECONDS_PER_DAY + +END function nsecondsinmonth + +!============================================================================== + +integer function nmonthinyearsec(year,basetime,calkindflag) + ! Compute month for year, basetime, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year + type(ESMF_BaseTime), intent(in) :: basetime + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + ! locals + TYPE(ESMF_BaseTime), pointer :: MMbdys(:) + integer :: mm,i + + IF ( isleap(year,calkindflag) ) THEN + MMbdys => monthbdysleap + ELSE + MMbdys => monthbdys + ENDIF + MM = -1 + DO i = 1,MONTHS_PER_YEAR + IF ( ( basetime >= MMbdys(i-1) ) .AND. ( basetime < MMbdys(i) ) ) THEN + MM = i + EXIT + ENDIF + ENDDO + IF ( MM == -1 ) THEN + CALL wrf_error_fatal( 'nmonthinyearsec: could not extract month of year from time' ) + ENDIF + nmonthinyearsec = mm + +END function nmonthinyearsec + +!============================================================================== +integer function ndayinyearsec(year, basetime, calkindflag) + ! Compute day of year for year, basetime, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year + type(ESMF_BaseTime), intent(in) :: basetime + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + ! locals + TYPE(ESMF_BaseTime), pointer :: MMbdys(:) + TYPE(ESMF_BaseTime) :: tmpbasetime + integer :: mm + + mm = nmonthinyearsec(year, basetime, calkindflag) + + IF ( isleap(year,calkindflag) ) THEN + MMbdys => monthbdysleap + ELSE + MMbdys => monthbdys + ENDIF + tmpbasetime = basetime - MMbdys(mm-1) + ndayinyearsec = ( tmpbasetime%S / SECONDS_PER_DAY ) + 1 + +end function ndayinyearsec +!============================================================================== +integer(esmf_kind_i8) function nsecondsinyearmonth(year, month, calkindflag) + ! Compute number of seconds from start of year for year, month, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year + INTEGER, INTENT(in) :: month + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + + ! locals + TYPE(ESMF_BaseTime), pointer :: MMbdys(:) + + IF ( ( MONTH < 1 ) .OR. ( MONTH > MONTHS_PER_YEAR ) ) THEN + CALL wrf_error_fatal( 'ERROR nsecondsinyearmonth(): MONTH out of range' ) + ENDIF + + IF ( isleap(year, calkindflag) ) THEN + MMbdys => monthbdysleap + ELSE + MMbdys => monthbdys + ENDIF + + nsecondsinyearmonth = MMbdys(month-1)%s + +end function nsecondsinyearmonth +!============================================================================== + +integer FUNCTION ndaysinyear ( year,calkindflag ) + ! Compute the number of days in the given year + IMPLICIT NONE + INTEGER, INTENT(IN) :: year + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + + IF ( isleap( year,calkindflag ) ) THEN + ndaysinyear = 366 + ELSE + ndaysinyear = 365 + ENDIF +END FUNCTION ndaysinyear + +!============================================================================== + +logical FUNCTION isleap ( year, calkindflag ) + ! Compute the number of days in February for the given year + IMPLICIT NONE + INTEGER,intent(in) :: year + type(ESMF_CalKind_Flag) :: calkindflag + ! local + INTEGER :: lyear + + lyear = abs(year) ! make sure it handles negative years + + isleap = .false. ! By default, February has 28 days ... + + if (calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype) then + IF (MOD(lyear,4).eq.0) THEN + isleap = .true. ! But every four years, it has 29 days ... + IF (MOD(lyear,100).eq.0) THEN + isleap = .false. ! Except every 100 years, when it has 28 days ... + IF (MOD(lyear,400).eq.0) THEN + isleap = .true. ! Except every 400 years, when it has 29 days. + END IF + END IF + END IF + endif + +END FUNCTION isleap + +!============================================================================== +end module ESMF_CalendarMod diff --git a/src/external/esmf_time_f90/ESMF_Clock.F90 b/src/external/esmf_time_f90/ESMF_ClockMod.F90 similarity index 77% rename from src/external/esmf_time_f90/ESMF_Clock.F90 rename to src/external/esmf_time_f90/ESMF_ClockMod.F90 index 6b5a3d09cd..d634362e8d 100644 --- a/src/external/esmf_time_f90/ESMF_Clock.F90 +++ b/src/external/esmf_time_f90/ESMF_ClockMod.F90 @@ -1,3 +1,4 @@ +! $Id$ ! ! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -5,7 +6,7 @@ ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. +! Licensed under the GPL. ! !============================================================================== ! @@ -38,8 +39,7 @@ module ESMF_ClockMod use ESMF_BaseMod ! associated derived types - use ESMF_TimeIntervalMod ! , only : ESMF_TimeInterval, & - ! ESMF_TimeIntervalIsPositive + use ESMF_TimeIntervalMod ! , only : ESMF_TimeInterval use ESMF_TimeMod ! , only : ESMF_Time use ESMF_AlarmMod, only : ESMF_Alarm @@ -54,6 +54,7 @@ module ESMF_ClockMod ! ! F90 class type to match C++ Clock class in size only; ! ! all dereferencing within class is performed by C++ implementation + ! internals for ESMF_Clock type ESMF_ClockInt type(ESMF_TimeInterval) :: TimeStep @@ -72,7 +73,7 @@ module ESMF_ClockMod ! as hideous as it might be because the ESMF_Alarm type ! has data members that are all POINTERs (thus the horrible ! shallow-copy-masquerading-as-reference-copy hack works). - type(ESMF_Alarm), pointer, dimension(:) :: AlarmList + type(ESMF_Alarm), pointer, dimension(:) :: AlarmList => null() end type ! Actual public type: this bit allows easy mimic of "deep" ESMF_ClockCreate @@ -80,7 +81,7 @@ module ESMF_ClockMod ! NOTE: DO NOT ADD NON-POINTER STATE TO THIS DATA TYPE. It emulates ESMF ! shallow-copy-masquerading-as-reference-copy. type ESMF_Clock - type(ESMF_ClockInt), pointer :: clockint + type(ESMF_ClockInt), pointer :: clockint => null() end type !------------------------------------------------------------------------------ @@ -123,6 +124,11 @@ module ESMF_ClockMod public ESMF_ClockPrint !EOPI +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + !============================================================================== contains @@ -271,15 +277,22 @@ FUNCTION ESMF_ClockCreate( name, TimeStep, StartTime, StopTime, & ESMF_ClockCreate = clocktmp END FUNCTION ESMF_ClockCreate - -! Deallocate memory for ESMF_Clock + ! + ! Deallocate memory for ESMF_Clock + ! SUBROUTINE ESMF_ClockDestroy( clock, rc ) + TYPE(ESMF_Clock), INTENT(INOUT) :: clock INTEGER, INTENT( OUT), OPTIONAL :: rc + + if (associated(clock%clockint)) then + if (associated(clock%clockint%AlarmList)) deallocate(clock%clockint%AlarmList) + deallocate(clock%clockint) + endif + ! TBH: ignore deallocate errors, for now - DEALLOCATE( clock%clockint%AlarmList ) - DEALLOCATE( clock%clockint ) IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + END SUBROUTINE ESMF_ClockDestroy @@ -287,10 +300,12 @@ END SUBROUTINE ESMF_ClockDestroy !BOP ! !IROUTINE: ESMF_ClockGet - Get clock properties -- for compatibility with ESMF 2.0.1 +! tcraig added alarmCount for ccsm4, consistent with ESMF3 interface + ! !INTERFACE: subroutine ESMF_ClockGet(clock, StartTime, CurrTime, & AdvanceCount, StopTime, TimeStep, & - PrevTime, RefTime, & + PrevTime, RefTime, AlarmCount, & rc) ! !ARGUMENTS: @@ -301,6 +316,7 @@ subroutine ESMF_ClockGet(clock, StartTime, CurrTime, & type(ESMF_Time), intent(out), optional :: PrevTime type(ESMF_Time), intent(out), optional :: RefTime integer(ESMF_KIND_I8), intent(out), optional :: AdvanceCount + integer, intent(out), optional :: AlarmCount type(ESMF_TimeInterval), intent(out), optional :: TimeStep integer, intent(out), optional :: rc integer :: ierr @@ -327,6 +343,8 @@ subroutine ESMF_ClockGet(clock, StartTime, CurrTime, & ! The {\tt ESMF\_Clock}'s previous current time ! \item[{[PrevTime]}] ! The {\tt ESMF\_Clock}'s reference time +! \item[{[AlarmCount]}] +! The {\tt ESMF\_Clock}'s number of valid alarms ! \item[{[rc]}] ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. ! \end{description} @@ -357,6 +375,9 @@ subroutine ESMF_ClockGet(clock, StartTime, CurrTime, & IF ( PRESENT (RefTime) ) THEN CALL ESMF_ClockGetRefTime(clock, RefTime, ierr) ENDIF + IF ( PRESENT (AlarmCount) ) THEN + CALL ESMF_ClockGetNumAlarms(clock, AlarmCount, ierr) + ENDIF IF ( PRESENT (rc) ) THEN rc = ierr @@ -441,7 +462,7 @@ end subroutine ESMF_ClockGetTimeStep subroutine ESMF_ClockSetTimeStep(clock, TimeStep, rc) ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: clock ! really INTENT(OUT) + type(ESMF_Clock), intent(inout) :: clock type(ESMF_TimeInterval), intent(in) :: TimeStep integer, intent(out), optional :: rc @@ -508,7 +529,7 @@ end subroutine ESMF_ClockGetCurrTime subroutine ESMF_ClockSetCurrTime(clock, CurrTime, rc) ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: clock ! really INTENT(OUT) + type(ESMF_Clock), intent(inout) :: clock type(ESMF_Time), intent(in) :: CurrTime integer, intent(out), optional :: rc @@ -663,11 +684,7 @@ subroutine ESMF_ClockGetPrevTime(clock, PrevTime, rc) ! TMG3.5.4 !EOP -! hack for bug in PGI 5.1-x -! prevTime = Clock%clockint%CurrTime - Clock%clockint%TimeStep - prevTime = ESMF_TimeDec( Clock%clockint%CurrTime, & - Clock%clockint%TimeStep ) - + prevTime = Clock%clockint%CurrTime - Clock%clockint%TimeStep IF ( PRESENT(rc) ) rc = ESMF_SUCCESS end subroutine ESMF_ClockGetPrevTime @@ -771,25 +788,16 @@ subroutine ESMF_ClockAddAlarm(clock, Alarm, rc) CALL wrf_error_fatal ( & 'ESMF_ClockAddAlarm: alarm not created' ) ELSE +!TBH: why do all this initialization here? IF ( Alarm%alarmint%RingTimeSet ) THEN - Alarm%alarmint%PrevRingTime = Alarm%alarmint%RingTime -!MGD: If the ring time is equal to the current time, the alarm should be ringing - IF (Alarm%alarmint%PrevRingTime == clock%clockint%CurrTime) THEN - Alarm%alarmint%Ringing = .TRUE. - ELSE - Alarm%alarmint%Ringing = .FALSE. - ENDIF + Alarm%alarmint%PrevRingTime = Alarm%alarmint%RingTime - & + Alarm%alarmint%RingInterval ELSE -!TBH: This has the nasty side-effect of forcing us to explicitly turn on -!TBH: alarms that are created with RingInterval only, if we want them to start -!TBH: ringing right away. And this is done (see -!TBH: COMPUTE_VORTEX_CENTER_ALARM). Straighten this out... Alarm%alarmint%PrevRingTime = clock%clockint%CurrTime - Alarm%alarmint%Ringing = .FALSE. ENDIF + Alarm%alarmint%Ringing = .FALSE. ! finally, load the alarm into the list -! write(0,*)'ESMF_ClockAddAlarm ',clock%clockint%NumAlarms clock%clockint%AlarmList(clock%clockint%NumAlarms) = Alarm ENDIF @@ -901,7 +909,7 @@ end subroutine ESMF_ClockSyncToWallClock subroutine ESMF_ClockAdvance(clock, RingingAlarmList, & NumRingingAlarms, rc) -use esmf_timemod +use ESMF_TimeMod ! !ARGUMENTS: type(ESMF_Clock), intent(inout) :: clock @@ -913,7 +921,6 @@ subroutine ESMF_ClockAdvance(clock, RingingAlarmList, & logical pred1, pred2, pred3 integer i, n type(ESMF_Alarm) :: alarm - logical :: positive_timestep ! ! !DESCRIPTION: ! Advance an {\tt ESMF\_Clock}'s current time by one time step @@ -933,12 +940,8 @@ subroutine ESMF_ClockAdvance(clock, RingingAlarmList, & ! !REQUIREMENTS: ! TMG3.4.1 !EOP -! hack for bug in PGI 5.1-x -! clock%clockint%CurrTime = clock%clockint%CurrTime + & -! clock%clockint%TimeStep - clock%clockint%CurrTime = ESMF_TimeInc( clock%clockint%CurrTime, & - clock%clockint%TimeStep ) - positive_timestep = ESMF_TimeIntervalIsPositive( clock%clockint%TimeStep ) + clock%clockint%CurrTime = clock%clockint%CurrTime + & + clock%clockint%TimeStep IF ( Present(NumRingingAlarms) ) NumRingingAlarms = 0 clock%clockint%AdvanceCount = clock%clockint%AdvanceCount + 1 @@ -952,162 +955,40 @@ subroutine ESMF_ClockAdvance(clock, RingingAlarmList, & IF ( alarm%alarmint%Enabled ) THEN IF ( alarm%alarmint%RingIntervalSet ) THEN pred1 = .FALSE. ; pred2 = .FALSE. ; pred3 = .FALSE. - ! alarm cannot ring if clock has passed the alarms stop time IF ( alarm%alarmint%StopTimeSet ) THEN -!MGD we probably want the same logic for before RingTime -!MGD IF ( positive_timestep ) THEN -! hack for bug in PGI 5.1-x -! PRED1 = clock%clockint%CurrTime > alarm%alarmint%StopTime - PRED1 = ESMF_TimeGT( clock%clockint%CurrTime, & - alarm%alarmint%StopTime ) -!MGD ELSE -!MGD ! in this case time step is negative and stop time is -!MGD ! less than start time -!MGD! PRED1 = clock%clockint%CurrTime < alarm%alarmint%StopTime -!MGD PRED1 = ESMF_TimeLT( clock%clockint%CurrTime, & -!MGD alarm%alarmint%StopTime ) -!MGD ENDIF - ELSE IF ( alarm%alarmint%RingTimeSet .AND. .NOT. PRED1) THEN -!MGD IF ( positive_timestep ) THEN -!MGD PRED1 = ESMF_TimeGT( clock%clockint%CurrTime, & -!MGD alarm%alarmint%RingTime ) -!MGD ELSE - PRED1 = ESMF_TimeLT( clock%clockint%CurrTime, & - alarm%alarmint%RingTime ) -!MGD ENDIF + PRED1 = clock%clockint%CurrTime > alarm%alarmint%StopTime ENDIF - ! one-shot alarm: check for ring time -! TBH: Need to remove duplicated code. Need to enforce only one of -! TBH: alarm%alarmint%RingTimeSet or alarm%alarmint%RingIntervalSet ever -! TBH: being .TRUE. and simplify the logic. Also, the simpler -! TBH: implementation in the duplicated code below should be sufficient. IF ( alarm%alarmint%RingTimeSet ) THEN - IF ( positive_timestep ) THEN -! hack for bug in PGI 5.1-x -! PRED2 = ( alarm%alarmint%RingTime <= clock%clockint%CurrTime & -! .AND. clock%clockint%CurrTime < alarm%alarmint%RingTime + & -! clock%clockint%TimeStep ) - PRED2 = ( ESMF_TimeLE( alarm%alarmint%RingTime, & - clock%clockint%CurrTime ) & - .AND. ESMF_TimeLT( clock%clockint%CurrTime, & - ESMF_TimeInc( alarm%alarmint%RingTime, & - clock%clockint%TimeStep ) ) ) - ELSE - ! in this case time step is negative and stop time is - ! less than start time -! hack for bug in PGI 5.1-x -! PRED2 = ( alarm%alarmint%RingTime >= clock%clockint%CurrTime & -! .AND. clock%clockint%CurrTime > alarm%alarmint%RingTime + & -! clock%clockint%TimeStep ) - PRED2 = ( ESMF_TimeGE( alarm%alarmint%RingTime, & - clock%clockint%CurrTime ) & - .AND. ESMF_TimeGT( clock%clockint%CurrTime, & - ESMF_TimeInc( alarm%alarmint%RingTime, & - clock%clockint%TimeStep ) ) ) - ENDIF + PRED2 = ( alarm%alarmint%RingTime <= clock%clockint%CurrTime & + .AND. clock%clockint%CurrTime < alarm%alarmint%RingTime + & + clock%clockint%TimeStep ) ENDIF - ! repeating alarm: check for ring interval IF ( alarm%alarmint%RingIntervalSet ) THEN - IF ( positive_timestep ) THEN -! hack for bug in PGI 5.1-x -! PRED3 = ( alarm%alarmint%PrevRingTime + alarm%alarmint%RingInterval <= & -! clock%clockint%CurrTime ) - - PRED3 = ( ESMF_TimeLE( ESMF_TimeInc( & - alarm%alarmint%PrevRingTime, & - alarm%alarmint%RingInterval ), & - clock%clockint%CurrTime ) ) - ELSE - ! in this case time step is negative and stop time is - ! less than start time - ! ring interval must always be positive -! hack for bug in PGI 5.1-x -! PRED3 = ( alarm%alarmint%PrevRingTime - alarm%alarmint%RingInterval >= & -! clock%clockint%CurrTime ) - - PRED3 = ( ESMF_TimeGE( ESMF_TimeDec( & - alarm%alarmint%PrevRingTime, & - alarm%alarmint%RingInterval ), & - clock%clockint%CurrTime ) ) - ENDIF + PRED3 = ( alarm%alarmint%PrevRingTime + alarm%alarmint%RingInterval <= & + clock%clockint%CurrTime ) ENDIF - IF ( (.NOT. pred1) .AND. pred2 ) THEN + IF ( ( .NOT. ( pred1 ) ) .AND. & + ( ( pred2 ) .OR. ( pred3 ) ) ) THEN alarm%alarmint%Ringing = .TRUE. - alarm%alarmint%PrevRingTime = clock%clockint%CurrTime -! MGD do we really want the line below? -! alarm%alarmint%RingTimeSet = .FALSE. !it is a one time alarm, it rang, now let it resort to interval + IF ( PRED3) alarm%alarmint%PrevRingTime = alarm%alarmint%PrevRingTime + & + alarm%alarmint%RingInterval IF ( PRESENT( RingingAlarmList ) .AND. & PRESENT ( NumRingingAlarms ) ) THEN NumRingingAlarms = NumRingingAlarms + 1 RingingAlarmList( NumRingingAlarms ) = alarm ENDIF - ELSE IF ( (.NOT. pred1) .AND. pred3 ) THEN + ENDIF + ELSE IF ( alarm%alarmint%RingTimeSet ) THEN + IF ( alarm%alarmint%RingTime <= clock%clockint%CurrTime ) THEN alarm%alarmint%Ringing = .TRUE. - IF ( positive_timestep ) THEN -! hack for bug in PGI 5.1-x -! IF ( PRED3) alarm%alarmint%PrevRingTime = alarm%alarmint%PrevRingTime + & -! alarm%alarmint%RingInterval - IF ( PRED3 ) & - alarm%alarmint%PrevRingTime = & - ESMF_TimeInc( alarm%alarmint%PrevRingTime, & - alarm%alarmint%RingInterval ) - ELSE - ! in this case time step is negative and stop time is - ! less than start time - ! ring interval must always be positive -! hack for bug in PGI 5.1-x -! IF ( PRED3) alarm%alarmint%PrevRingTime = alarm%alarmint%PrevRingTime - & -! alarm%alarmint%RingInterval - IF ( PRED3 ) & - alarm%alarmint%PrevRingTime = & - ESMF_TimeDec( alarm%alarmint%PrevRingTime, & - alarm%alarmint%RingInterval ) - ENDIF IF ( PRESENT( RingingAlarmList ) .AND. & PRESENT ( NumRingingAlarms ) ) THEN NumRingingAlarms = NumRingingAlarms + 1 RingingAlarmList( NumRingingAlarms ) = alarm ENDIF ENDIF - ELSE IF ( alarm%alarmint%RingTimeSet ) THEN -! TBH: Need to remove duplicated code. Need to enforce only one of -! TBH: alarm%alarmint%RingTimeSet or alarm%alarmint%RingIntervalSet ever -! TBH: being .TRUE. and simplify the logic. Also, the simpler -! TBH: implementation in here should be sufficient. - IF ( positive_timestep ) THEN -! hack for bug in PGI 5.1-x -! IF ( alarm%alarmint%RingTime <= clock%clockint%CurrTime ) THEN - IF ( ESMF_TimeLE( alarm%alarmint%RingTime, & - clock%clockint%CurrTime ) ) THEN - alarm%alarmint%RingTimeSet = .FALSE. !it is a one time alarm, it rang, now let it resort to interval - alarm%alarmint%Ringing = .TRUE. - alarm%alarmint%PrevRingTime = clock%clockint%CurrTime - IF ( PRESENT( RingingAlarmList ) .AND. & - PRESENT ( NumRingingAlarms ) ) THEN - NumRingingAlarms = NumRingingAlarms + 1 - RingingAlarmList( NumRingingAlarms ) = alarm - ENDIF - ENDIF - ELSE - ! in this case time step is negative and stop time is - ! less than start time -! hack for bug in PGI 5.1-x -! IF ( alarm%alarmint%RingTime >= clock%clockint%CurrTime ) THEN - IF ( ESMF_TimeGE( alarm%alarmint%RingTime, & - clock%clockint%CurrTime ) ) THEN - alarm%alarmint%RingTimeSet = .FALSE. !it is a one time alarm, it rang, now let it resort to interval - alarm%alarmint%Ringing = .TRUE. - alarm%alarmint%PrevRingTime = clock%clockint%CurrTime - IF ( PRESENT( RingingAlarmList ) .AND. & - PRESENT ( NumRingingAlarms ) ) THEN - NumRingingAlarms = NumRingingAlarms + 1 - RingingAlarmList( NumRingingAlarms ) = alarm - ENDIF - ENDIF - ENDIF ENDIF IF ( alarm%alarmint%StopTimeSet ) THEN -! TBH: what is this for??? ENDIF ENDIF ENDIF @@ -1145,7 +1026,6 @@ function ESMF_ClockIsStopTime(clock, rc) ! !ARGUMENTS: type(ESMF_Clock), intent(in) :: clock integer, intent(out), optional :: rc - logical :: positive_timestep ! !DESCRIPTION: ! Return true if {\tt ESMF\_Clock} has reached its stop time, false @@ -1163,26 +1043,11 @@ function ESMF_ClockIsStopTime(clock, rc) ! TMG3.5.6 !EOP - positive_timestep = ESMF_TimeIntervalIsPositive( clock%clockint%TimeStep ) - IF ( positive_timestep ) THEN -! hack for bug in PGI 5.1-x -! if ( clock%clockint%CurrTime .GE. clock%clockint%StopTime ) THEN - if ( ESMF_TimeGE( clock%clockint%CurrTime, & - clock%clockint%StopTime ) ) THEN - ESMF_ClockIsStopTime = .TRUE. - else - ESMF_ClockIsStopTime = .FALSE. - endif - ELSE -! hack for bug in PGI 5.1-x -! if ( clock%clockint%CurrTime .LE. clock%clockint%StopTime ) THEN - if ( ESMF_TimeLE( clock%clockint%CurrTime, & - clock%clockint%StopTime ) ) THEN - ESMF_ClockIsStopTime = .TRUE. - else - ESMF_ClockIsStopTime = .FALSE. - endif - ENDIF + if ( clock%clockint%CurrTime .GE. clock%clockint%StopTime ) THEN + ESMF_ClockIsStopTime = .TRUE. + else + ESMF_ClockIsStopTime = .FALSE. + endif IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS end function ESMF_ClockIsStopTime @@ -1358,7 +1223,25 @@ subroutine ESMF_ClockPrint(clock, opts, rc) ! !REQUIREMENTS: ! TMGn.n.n !EOP - CALL wrf_error_fatal( 'ESMF_ClockPrint not supported' ) + type(ESMF_Time) :: start_time + type(ESMF_Time) :: stop_time + type(ESMF_Time) :: curr_time + type(ESMF_Time) :: ref_time + type(ESMF_TimeInterval) :: timestep + + call ESMF_ClockGet( clock, startTime=start_time, & + stoptime=stop_time, currTime=curr_time, & + refTime=ref_time, timeStep=timestep, rc=rc ) + print *, 'Start time: ' + call ESMF_TimePrint( start_time ) + print *, 'Stop time: ' + call ESMF_TimePrint( stop_time ) + print *, 'Reference time: ' + call ESMF_TimePrint( ref_time ) + print *, 'Current time: ' + call ESMF_TimePrint( curr_time ) + print *, 'Time step: ' + call ESMF_TimeIntervalPrint( timestep) end subroutine ESMF_ClockPrint !------------------------------------------------------------------------------ diff --git a/src/external/esmf_time_f90/ESMF_Fraction.F90 b/src/external/esmf_time_f90/ESMF_FractionMod.F90 similarity index 90% rename from src/external/esmf_time_f90/ESMF_Fraction.F90 rename to src/external/esmf_time_f90/ESMF_FractionMod.F90 index cb8b9662fc..7f451f3d0c 100644 --- a/src/external/esmf_time_f90/ESMF_Fraction.F90 +++ b/src/external/esmf_time_f90/ESMF_FractionMod.F90 @@ -1,3 +1,4 @@ +! $Id$ ! ! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -5,7 +6,7 @@ ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. +! Licensed under the GPL. ! ! ESMF Fraction Module ! @@ -63,6 +64,11 @@ module ESMF_FractionMod !EOPI +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + !============================================================================== ! contains diff --git a/src/external/esmf_time_f90/ESMF_Macros.inc b/src/external/esmf_time_f90/ESMF_Macros.inc index 9ffbf2ffc8..896190e742 100644 --- a/src/external/esmf_time_f90/ESMF_Macros.inc +++ b/src/external/esmf_time_f90/ESMF_Macros.inc @@ -1,4 +1,5 @@ #if 0 +$Id$ Earth System Modeling Framework Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -6,7 +7,7 @@ Massachusetts Institute of Technology, Geophysical Fluid Dynamics Laboratory, University of Michigan, National Centers for Environmental Prediction, Los Alamos National Laboratory, Argonne National Laboratory, NASA Goddard Space Flight Center. -Licensed under the University of Illinois-NCSA license. +Licensed under the GPL. Do not have C++ or F90 style comments in here because this file is processed by both C++ and F90 compilers. diff --git a/src/external/esmf_time_f90/ESMF_Mod.F90 b/src/external/esmf_time_f90/ESMF_Mod.F90 deleted file mode 100644 index 8c4c260cfc..0000000000 --- a/src/external/esmf_time_f90/ESMF_Mod.F90 +++ /dev/null @@ -1,17 +0,0 @@ -! TBH: This version is for use with the ESMF library embedded in the WRF -! TBH: distribution. -MODULE ESMF_Mod - USE esmf_alarmmod - USE esmf_basemod - USE esmf_basetimemod - USE esmf_calendarmod - USE esmf_clockmod - USE esmf_fractionmod - USE esmf_timeintervalmod - USE esmf_timemod - USE esmf_alarmclockmod - USE esmf_stubs ! add new dummy interfaces and typedefs here as needed -#include - INTEGER, PARAMETER :: ESMF_MAX_ALARMS=MAX_ALARMS -! -END MODULE ESMF_Mod diff --git a/src/external/esmf_time_f90/ESMF_ShrTimeMod.F90 b/src/external/esmf_time_f90/ESMF_ShrTimeMod.F90 new file mode 100644 index 0000000000..2a4364fac0 --- /dev/null +++ b/src/external/esmf_time_f90/ESMF_ShrTimeMod.F90 @@ -0,0 +1,45 @@ + module ESMF_ShrTimeMod +! +!============================================================================== +! +! This file contains types and methods that are shared in the hierarchy +! +!------------------------------------------------------------------------------ +! INCLUDES + +!============================================================================== +!BOPI +! !MODULE: ESMF_ShrTimeMod +! +! !DESCRIPTION: +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit from ESMF base class + use ESMF_BaseMod + + ! inherit from base time class + use ESMF_BaseTimeMod + use ESMF_CalendarMod + + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ +! ! ESMF_Time +! +! ! F90 class type to match C++ Time class in size only; +! ! all dereferencing within class is performed by C++ implementation + + type ESMF_Time + type(ESMF_BaseTime) :: basetime ! inherit base class + ! time instant is expressed as year + basetime + integer :: YR + type(ESMF_Calendar), pointer :: calendar => null() ! associated calendar + end type + + public ESMF_Time +!============================================================================== +end module ESMF_ShrTimeMod diff --git a/src/external/esmf_time_f90/ESMF_Stubs.F90 b/src/external/esmf_time_f90/ESMF_Stubs.F90 index 6b00e27944..4c144e2bdc 100644 --- a/src/external/esmf_time_f90/ESMF_Stubs.F90 +++ b/src/external/esmf_time_f90/ESMF_Stubs.F90 @@ -25,6 +25,14 @@ MODULE ESMF_Stubs INTEGER :: dummy END TYPE + TYPE ESMF_END_FLAG + INTEGER :: dummy + END TYPE + TYPE(ESMF_END_FLAG), PARAMETER :: & + ESMF_END_ABORT = ESMF_END_FLAG(1), & + ESMF_END_NORMAL = ESMF_END_FLAG(2), & + ESMF_END_KEEPMPI = ESMF_END_FLAG(3) + TYPE ESMF_MsgType INTEGER :: mtype END TYPE @@ -41,21 +49,23 @@ MODULE ESMF_Stubs PUBLIC ESMF_Grid, ESMF_GridComp, ESMF_State, ESMF_VM PUBLIC ESMF_Initialize, ESMF_Finalize, ESMF_IsInitialized - PUBLIC ESMF_LogWrite, ESMF_LOG, ESMF_MsgType + PUBLIC ESMF_LogWrite, ESMF_LOG, ESMF_MsgType, ESMF_END_FLAG PUBLIC ESMF_LOG_INFO, ESMF_LOG_WARNING, ESMF_LOG_ERROR + PUBLIC ESMF_END_ABORT, ESMF_END_NORMAL, ESMF_END_KEEPMPI CONTAINS ! NOOP SUBROUTINE ESMF_Initialize( vm, defaultCalendar, rc ) - USE esmf_basemod - USE esmf_calendarmod + USE ESMF_BaseMod + USE ESMF_CalendarMod +! USE ESMF_TimeMod, only: defaultCal TYPE(ESMF_VM), INTENT(IN ), OPTIONAL :: vm - TYPE(ESMF_CalendarType), INTENT(IN ), OPTIONAL :: defaultCalendar + TYPE(ESMF_CalKind_Flag), INTENT(IN ), OPTIONAL :: defaultCalendar INTEGER, INTENT( OUT), OPTIONAL :: rc - TYPE(ESMF_CalendarType) :: defaultCalType + TYPE(ESMF_CalKind_Flag) :: defaultCalType INTEGER :: status IF ( PRESENT( rc ) ) rc = ESMF_FAILURE @@ -63,11 +73,29 @@ SUBROUTINE ESMF_Initialize( vm, defaultCalendar, rc ) IF ( PRESENT(defaultCalendar) )THEN defaultCalType = defaultCalendar ELSE - defaultCalType = ESMF_CAL_NOLEAP + defaultCalType = ESMF_CALKIND_NOLEAP END IF allocate( defaultCal ) - defaultCal = ESMF_CalendarCreate( calendarType=defaultCalType, & +! write(6,*) 'tcx1 ESMF_Stubs defcal ',defaultcaltype%caltype +! call flush(6) + defaultCal = ESMF_CalendarCreate( calkindflag=defaultCalType, & + rc=status) +! write(6,*) 'tcx2 ESMF_Stubs defcal ',defaultcal%type%caltype +! call flush(6) + allocate( gregorianCal ) +! write(6,*) 'tcx1 ESMF_Stubs grcal ',esmf_calkind_gregorian%caltype +! call flush(6) + gregorianCal = ESMF_CalendarCreate( calkindflag=ESMF_CALKIND_GREGORIAN, & rc=status) +! write(6,*) 'tcx2 ESMF_Stubs grcal ',gregoriancal%type%caltype +! call flush(6) + allocate( noleapCal ) +! write(6,*) 'tcx1 ESMF_Stubs nlcal ',esmf_calkind_noleap%caltype +! call flush(6) + noleapCal = ESMF_CalendarCreate( calkindflag=ESMF_CALKIND_NOLEAP, & + rc=status) +! write(6,*) 'tcx2 ESMF_Stubs nlcal ',noleapcal%type%caltype +! call flush(6) ! initialize tables in time manager CALL initdaym @@ -89,37 +117,27 @@ END FUNCTION ESMF_IsInitialized ! NOOP - SUBROUTINE ESMF_Finalize( rc ) - USE esmf_basemod - USE esmf_calendarmod - + SUBROUTINE ESMF_Finalize( endflag, rc ) + USE ESMF_BaseMod + type(ESMF_END_FLAG), intent(in), optional :: endflag INTEGER, INTENT( OUT), OPTIONAL :: rc -#if (defined SPMD) || (defined COUP_CSM) +#ifndef HIDE_MPI #include #endif - LOGICAL :: flag INTEGER :: ier - CALL ESMF_CalendarDestroy() - IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS -#if (defined SPMD) || (defined COUP_CSM) - CALL MPI_Finalized( flag, ier ) +#ifndef HIDE_MPI + CALL MPI_Finalize( ier ) IF ( ier .ne. mpi_success )THEN IF ( PRESENT( rc ) ) rc = ESMF_FAILURE END IF - IF ( .NOT. flag ) THEN - CALL MPI_Finalize( ier ) - IF ( ier .ne. mpi_success )THEN - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - END IF - END IF #endif END SUBROUTINE ESMF_Finalize ! NOOP SUBROUTINE ESMF_LogWrite( msg, MsgType, line, file, method, log, rc ) - USE esmf_basemod + USE ESMF_BaseMod CHARACTER(LEN=*), INTENT(IN) :: msg TYPE(ESMF_MsgType), INTENT(IN) :: msgtype INTEGER, INTENT(IN), OPTIONAL :: line diff --git a/src/external/esmf_time_f90/ESMF_TimeInterval.F90 b/src/external/esmf_time_f90/ESMF_TimeIntervalMod.F90 similarity index 63% rename from src/external/esmf_time_f90/ESMF_TimeInterval.F90 rename to src/external/esmf_time_f90/ESMF_TimeIntervalMod.F90 index 95d4edc5a1..5d8be4e738 100644 --- a/src/external/esmf_time_f90/ESMF_TimeInterval.F90 +++ b/src/external/esmf_time_f90/ESMF_TimeIntervalMod.F90 @@ -1,3 +1,4 @@ +! $Id$ ! ! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -5,12 +6,14 @@ ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. +! Licensed under the GPL. ! !============================================================================== ! ! ESMF TimeInterval Module - module ESMF_TimeIntervalMod + +module ESMF_TimeIntervalMod + ! !============================================================================== ! @@ -44,6 +47,7 @@ module ESMF_TimeIntervalMod ! associated derived types use ESMF_FractionMod, only : ESMF_Fraction use ESMF_CalendarMod + use ESMF_ShrTimeMod, only : ESMF_Time implicit none ! @@ -63,8 +67,9 @@ module ESMF_TimeIntervalMod ! intervals. Many operations are undefined when these fields are ! non-zero! INTEGER :: YR ! relative year - !jm Month has no meaning for an interval; get rid of it, 20100319 - ! INTEGER :: MM ! relative month + INTEGER :: MM ! relative month + logical :: starttime_set ! reference time set + type(ESMF_Time) :: starttime ! reference time end type !------------------------------------------------------------------------------ @@ -72,24 +77,22 @@ module ESMF_TimeIntervalMod public ESMF_TimeInterval !------------------------------------------------------------------------------ ! +! for running WRF, add three subroutines or functions (WRFADDITION_TimeIntervalGet, +! ESMF_TimeIntervalDIVQuot, ESMF_TimeIntervalIsPositive), by jhe ! !PUBLIC MEMBER FUNCTIONS: public ESMF_TimeIntervalGet public ESMF_TimeIntervalSet - public ESMFold_TimeIntervalGetString public ESMF_TimeIntervalAbsValue public ESMF_TimeIntervalNegAbsValue + public ESMF_TimeIntervalPrint + public normalize_timeint ! Required inherited and overridden ESMF_Base class methods -!!!!!!!!! added 20051012, JM -! public WRFADDITION_TimeIntervalDIVQuot -!!!!!!!!! renamed to simplify testing 20060320, TH - public ESMF_TimeIntervalDIVQuot - - ! This convenience routine is only used by other modules in - ! esmf_time_f90. - public ESMF_TimeIntervalIsPositive - +!!!!!!!!! added by jhe + public ESMF_TimeIntervalDIVQuot + public ESMF_TimeIntervalIsPositive +! ! !PRIVATE MEMBER FUNCTIONS: @@ -128,6 +131,11 @@ module ESMF_TimeIntervalMod private ESMF_TimeIntervalGE !EOPI +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + !============================================================================== ! ! INTERFACE BLOCKS @@ -292,22 +300,24 @@ module ESMF_TimeIntervalMod ! ! Generic Get/Set routines which use F90 optional arguments ! -!------------------------------------------------------------------------------ +!--------------------------------------------------------------------- !BOP ! !IROUTINE: ESMF_TimeIntervalGet - Get value in user-specified units ! !INTERFACE: - subroutine ESMF_TimeIntervalGet(timeinterval, D, d_r8, S, S_i8, Sn, Sd, & - TimeString, rc ) + subroutine ESMF_TimeIntervalGet(timeinterval, StartTimeIn, yy, mm, D, d_r8, S, S_i8, Sn, Sd, TimeString, rc ) ! !ARGUMENTS: type(ESMF_TimeInterval), intent(in) :: timeinterval + type(ESMF_Time), optional, intent(in) :: StartTimeIn + integer, intent(out), optional :: yy + integer, intent(out), optional :: mm integer, intent(out), optional :: D - real(ESMF_KIND_R8), intent(out), optional :: d_r8 - integer(ESMF_KIND_I8), intent(out), optional :: S_i8 + real(ESMF_KIND_R8), intent(out), optional :: d_r8 + integer(ESMF_KIND_I8),intent(out), optional :: S_i8 integer, intent(out), optional :: S integer, intent(out), optional :: Sn - integer, intent(out), optional :: Sd + integer, intent(out), optional :: Sd character*(*), optional, intent(out) :: TimeString integer, intent(out), optional :: rc @@ -377,40 +387,150 @@ subroutine ESMF_TimeIntervalGet(timeinterval, D, d_r8, S, S_i8, Sn, Sd, & ! ! !REQUIREMENTS: ! TMG1.1 -! -! Added argument to output double precision seconds, S_i8 -! William.Gustafson@pnl.gov; 9-May-2008 -! !EOP - INTEGER(ESMF_KIND_I8) :: seconds + type(ESMF_Time) :: lstarttime + logical :: lstarttime_set + logical :: doyear + INTEGER(ESMF_KIND_I8) :: seconds, secondsym, years INTEGER :: ierr + INTEGER :: mpyi4, iyr,imo,mmon,nmon,mstart,ndays - ierr = ESMF_SUCCESS + ierr = ESMF_FAILURE + + if (present(StartTimeIn)) then + lstarttime_set = .true. + lstarttime = StartTimeIn + else + lstarttime_set = timeinterval%StartTime_set + lstarttime = timeinterval%StartTime + endif + + + CALL timeintchecknormalized( timeinterval, & + 'ESMF_TimeIntervalGet arg1', & + relative_interval=.true. ) seconds = timeinterval%basetime%S - ! note that S is overwritten below (if present) if other args are also - ! present - IF ( PRESENT(S) ) S = seconds - IF ( PRESENT(S_i8) ) S_i8 = seconds - IF ( PRESENT( D ) ) THEN + years = timeinterval%YR + + secondsym = 0 + + IF ( PRESENT( YY ) )THEN + YY = years + timeinterval%MM / MONTHS_PER_YEAR +! seconds = seconds - years * ( 365_ESMF_KIND_I8 * SECONDS_PER_DAY ) + IF ( PRESENT( MM ) )THEN + mpyi4 = MONTHS_PER_YEAR + MM = MOD( timeinterval%MM, mpyi4) + else + call wrf_error_fatal("ESMF_TimeIntervalGet: requires MM with YY") + END IF + ELSE IF ( PRESENT( MM ) )THEN + MM = timeinterval%MM + years*12 + else if (lstarttime_set) then + ! convert years and months to days carefully + + mpyi4 = MONTHS_PER_YEAR + mmon = timeinterval%mm + timeinterval%yr*mpyi4 + mstart = nmonthinyearsec(lstarttime%yr,lstarttime%basetime,lstarttime%calendar%type) +! write(6,*) 'tcxti1 ',mmon,lstarttime%yr,mstart,lstarttime%basetime%s + + iyr = lstarttime%yr + if (mmon > 0) then + imo = mstart-1 ! if adding months, start with this month after adding first +1 + else + imo = mstart ! if going backwards, start with last month after first -1 + endif + nmon = 1 +! do nmon = 1,abs(mmon) + do while (nmon <= abs(mmon)) + if (mmon > 0) then + if (imo == 12 .and. (abs(mmon) - nmon) > 12) then + iyr = iyr + 1 + nmon = nmon + 12 + doyear = .true. + else + imo = imo + 1 + nmon = nmon + 1 + doyear = .false. + endif + else + if (imo == 1 .and. (abs(mmon) - nmon) > 12) then + iyr = iyr - 1 + nmon = nmon + 12 + doyear = .true. + else + imo = imo - 1 + nmon = nmon + 1 + doyear = .false. + endif + endif + + do while (imo > 12) + imo = imo - 12 + iyr = iyr + 1 + enddo + do while (imo < 1) + imo = imo + 12 + iyr = iyr - 1 + enddo + + if (doyear) then + ndays = ndaysinyear(iyr,lstarttime%calendar%type) + else + ndays = ndaysinmonth(iyr,imo,lstarttime%calendar%type) + endif + secondsym = secondsym + (ndays * SECONDS_PER_DAY) +! write(6,*) 'tcxti2 ',nmon,iyr,imo,ndays + enddo + if (mmon < 0) then + secondsym = -secondsym + endif +! write(6,*) 'tcxti3 ',mmon,iyr,imo,secondsym + elseif (PRESENT(D) .or. PRESENT(d_r8) .or. present(S) .or. present(S_i8)) then + IF (timeinterval%MM /= 0) then + CALL wrf_error_fatal("ESMF_TimeIntervalGet: Need MM with D,d_r8,S,or S_i8") + endif + if (timeinterval%YR /= 0) then + CALL wrf_error_fatal("ESMF_TimeIntervalGet: Need YY or MM with D,d_r8,S,or S_i8") + endif + END IF + + seconds = seconds+secondsym + + IF ( PRESENT( D ) )THEN D = seconds / SECONDS_PER_DAY - IF ( PRESENT(S) ) S = MOD( seconds, SECONDS_PER_DAY ) - IF ( PRESENT(S_i8) ) S_i8 = MOD( seconds, SECONDS_PER_DAY ) - ENDIF - IF ( PRESENT( d_r8 ) ) THEN + IF ( PRESENT(S) ) S = mod( seconds, SECONDS_PER_DAY ) + IF ( PRESENT(S_i8)) S_i8 = mod( seconds, SECONDS_PER_DAY ) + ELSE + IF ( PRESENT(S) ) S = seconds + IF ( PRESENT(S_i8)) S_i8 = seconds + END IF + + IF ( PRESENT( d_r8 ) )THEN D_r8 = REAL( seconds, ESMF_KIND_R8 ) / & REAL( SECONDS_PER_DAY, ESMF_KIND_R8 ) - IF ( PRESENT(S) ) S = MOD( seconds, SECONDS_PER_DAY ) - IF ( PRESENT(S_i8) ) S_i8 = MOD( seconds, SECONDS_PER_DAY ) + END IF + + ! If d_r8 present and sec present + IF ( PRESENT( d_r8 ) )THEN + IF ( PRESENT( S ) .or. present(s_i8) )THEN + CALL wrf_error_fatal( & + "ESMF_TimeIntervalGet: Can not specify d_r8 and S S_i8 values" ) + END IF + END IF + + ierr = ESMF_SUCCESS + + IF ( PRESENT( timeString ) ) THEN + CALL ESMFold_TimeIntervalGetString( timeinterval, timeString, rc=ierr ) ENDIF + IF ( PRESENT(Sn) ) THEN Sn = timeinterval%basetime%Sn ENDIF IF ( PRESENT(Sd) ) THEN Sd = timeinterval%basetime%Sd ENDIF - IF ( PRESENT( timeString ) ) THEN - CALL ESMFold_TimeIntervalGetString( timeinterval, timeString, rc=ierr ) - ENDIF + IF ( PRESENT(rc) ) rc = ierr end subroutine ESMF_TimeIntervalGet @@ -420,38 +540,45 @@ end subroutine ESMF_TimeIntervalGet ! !IROUTINE: ESMF_TimeIntervalSet - Initialize via user-specified unit set ! !INTERFACE: - subroutine ESMF_TimeIntervalSet(timeinterval, YY, YYl, MM, MOl, D, Dl, & - H, M, S, Sl, MS, US, NS, & - d_, h_, m_, s_, ms_, us_, ns_, & - Sn, Sd, rc) +! subroutine ESMF_TimeIntervalSet(timeinterval, YY, YYl, MM, MOl, D, Dl, & +! H, M, S, Sl, MS, US, NS, & +! d_, d_r8, h_, m_, s_, ms_, us_, ns_, & +! Sn, Sd, startTime, rc) + subroutine ESMF_TimeIntervalSet(timeinterval, YY, MM, D, & + H, M, S, S_i8, MS, & + d_, d_r8, & + Sn, Sd, startTime, rc) ! !ARGUMENTS: type(ESMF_TimeInterval), intent(out) :: timeinterval + type(ESMF_Time), intent(in), optional :: StartTime integer, intent(in), optional :: YY - integer(ESMF_KIND_I8), intent(in), optional :: YYl +! integer(ESMF_KIND_I8), intent(in), optional :: YYl integer, intent(in), optional :: MM - integer(ESMF_KIND_I8), intent(in), optional :: MOl +! integer(ESMF_KIND_I8), intent(in), optional :: MOl integer, intent(in), optional :: D - integer(ESMF_KIND_I8), intent(in), optional :: Dl +! integer(ESMF_KIND_I8), intent(in), optional :: Dl integer, intent(in), optional :: H integer, intent(in), optional :: M integer, intent(in), optional :: S - integer(ESMF_KIND_I8), intent(in), optional :: Sl + integer(ESMF_KIND_I8), intent(in), optional :: S_i8 integer, intent(in), optional :: MS - integer, intent(in), optional :: US - integer, intent(in), optional :: NS +! integer, intent(in), optional :: US +! integer, intent(in), optional :: NS double precision, intent(in), optional :: d_ - double precision, intent(in), optional :: h_ - double precision, intent(in), optional :: m_ - double precision, intent(in), optional :: s_ - double precision, intent(in), optional :: ms_ - double precision, intent(in), optional :: us_ - double precision, intent(in), optional :: ns_ + double precision, intent(in), optional :: d_r8 +! double precision, intent(in), optional :: h_ +! double precision, intent(in), optional :: m_ +! double precision, intent(in), optional :: s_ +! double precision, intent(in), optional :: ms_ +! double precision, intent(in), optional :: us_ +! double precision, intent(in), optional :: ns_ integer, intent(in), optional :: Sn integer, intent(in), optional :: Sd integer, intent(out), optional :: rc ! locals - INTEGER :: nfeb + double precision :: din + logical :: dinset ! !DESCRIPTION: ! Set the value of the {\tt ESMF\_TimeInterval} in units specified by @@ -521,48 +648,67 @@ subroutine ESMF_TimeIntervalSet(timeinterval, YY, YYl, MM, MOl, D, Dl, & !EOP IF ( PRESENT(rc) ) rc = ESMF_FAILURE + + timeinterval%startTime_set = .false. + if (present(startTime)) then + timeinterval%startTime = startTime + timeinterval%startTime_set = .true. + endif + ! note that YR and MM are relative timeinterval%YR = 0 IF ( PRESENT( YY ) ) THEN timeinterval%YR = YY ENDIF -!jm timeinterval%MM = 0 -!jm IF ( PRESENT( MM ) ) THEN -!jm timeinterval%MM = MM -!jm ENDIF -!jm ! Rollover months to years -!jm IF ( abs(timeinterval%MM) .GE. MONTHS_PER_YEAR ) THEN -!jm timeinterval%YR = timeinterval%YR + timeinterval%MM/MONTHS_PER_YEAR -!jm timeinterval%MM = mod(timeinterval%MM,MONTHS_PER_YEAR) -!jm ENDIF - - timeinterval%basetime%S = 0 - ! For 365-day calendar, immediately convert years to days since we know - ! how to do it in this case. -!$$$ replace this hack with something saner... - IF ( nfeb( 2004 ) == 28 ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - ( 365_ESMF_KIND_I8 * & - INT( timeinterval%YR, ESMF_KIND_I8 ) * SECONDS_PER_DAY ) - timeinterval%YR = 0 - ENDIF - IF ( PRESENT( D ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - ( SECONDS_PER_DAY * INT( D, ESMF_KIND_I8 ) ) + timeinterval%MM = 0 + IF ( PRESENT( MM ) ) THEN + timeinterval%MM = MM ENDIF -!$$$ Push H,M,S,Sn,Sd,MS down into BaseTime constructor from EVERYWHERE -!$$$ and THEN add ESMF scaling behavior when other args are present... - IF ( PRESENT( H ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - ( SECONDS_PER_HOUR * INT( H, ESMF_KIND_I8 ) ) - ENDIF - IF ( PRESENT( M ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - ( SECONDS_PER_MINUTE * INT( M, ESMF_KIND_I8 ) ) + + if (present(d_) .and. present(d_r8)) then + CALL wrf_error_fatal( & + "ESMF_TimeIntervalSet: Cannot specify both d_r8 and d_") + endif + dinset = .false. + if (present(d_)) then + din = d_ + dinset = .true. + endif + if (present(d_r8)) then + din = d_r8 + dinset = .true. + endif + IF ( dinset .AND. PRESENT( D ) ) THEN + CALL wrf_error_fatal( & + "ESMF_TimeIntervalSet: Cannot specify both D and d_ or d_r8") ENDIF - IF ( PRESENT( S ) ) THEN - timeinterval%basetime%S = timeinterval%basetime%S + & - INT( S, ESMF_KIND_I8 ) + + timeinterval%basetime%S = 0 + IF ( .NOT. dinset ) THEN + IF ( PRESENT( D ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + ( SECONDS_PER_DAY * INT( D, ESMF_KIND_I8 ) ) + ENDIF +!$$$ push H,M,S,Sn,Sd,MS down into BaseTime constructor + IF ( PRESENT( H ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + ( SECONDS_PER_HOUR * INT( H, ESMF_KIND_I8 ) ) + ENDIF + IF ( PRESENT( M ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + ( SECONDS_PER_MINUTE * INT( M, ESMF_KIND_I8 ) ) + ENDIF + IF ( PRESENT( S ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + INT( S, ESMF_KIND_I8 ) + ENDIF + IF ( PRESENT( S_i8 ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + ( S_i8) + ENDIF + ELSE + timeinterval%basetime%S = timeinterval%basetime%S + & + INT( din * SECONDS_PER_DAY, ESMF_KIND_I8 ) ENDIF IF ( PRESENT( Sn ) .AND. ( .NOT. PRESENT( Sd ) ) ) THEN CALL wrf_error_fatal( & @@ -601,9 +747,9 @@ subroutine ESMFold_TimeIntervalGetString(timeinterval, TimeString, rc) character*(*), intent(out) :: TimeString integer, intent(out), optional :: rc ! locals - integer :: signnormtimeint +! integer :: signnormtimeint LOGICAL :: negative - INTEGER(ESMF_KIND_I8) :: iS, iSn, iSd, H, M, S + INTEGER(ESMF_KIND_I8) :: iS, iSn, iSd, H, M, S, MM, D, YY character (len=1) :: signstr ! !DESCRIPTION: @@ -623,7 +769,7 @@ subroutine ESMFold_TimeIntervalGetString(timeinterval, TimeString, rc) ! TMG1.5.9 !EOP -! NOTE: YR, MM, Sn, and Sd are not yet included in the returned string... +! NOTE: Sn, and Sd are not yet included in the returned string... !PRINT *,'DEBUG ESMFold_TimeIntervalGetString(): YR,MM,S,Sn,Sd = ', & ! timeinterval%YR, & ! timeinterval%MM, & @@ -643,14 +789,28 @@ subroutine ESMFold_TimeIntervalGetString(timeinterval, TimeString, rc) ENDIF iSd = timeinterval%basetime%Sd + D = iS / SECONDS_PER_DAY H = mod( iS, SECONDS_PER_DAY ) / SECONDS_PER_HOUR M = mod( iS, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE S = mod( iS, SECONDS_PER_MINUTE ) !$$$here... need to print Sn and Sd when they are used ??? - write(TimeString,FMT="(A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & - TRIM(signstr), ( iS / SECONDS_PER_DAY ), H, M, S + CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalGetString-arg1', & + relative_interval=.true. ) + IF ( (timeinterval%MM == 0) .AND. (timeinterval%YR == 0) )THEN + write(TimeString,FMT="(A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & + TRIM(signstr), D, H, M, S + ELSEif (timeinterval%YR == 0) then + MM = timeinterval%MM + write(TimeString,FMT="(I4.4, '_Months_',A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & + MM, TRIM(signstr), D, H, M, S + else + YY = timeinterval%YR + MM = timeinterval%MM + write(TimeString,FMT="(I6.6,'_Years_',I4.4, '_Months_',A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & + YY, MM, TRIM(signstr), D, H, M, S + END IF !write(0,*)'TimeIntervalGetString Sn ',timeinterval%basetime%Sn,' Sd ',timeinterval%basetime%Sd @@ -686,13 +846,17 @@ function ESMF_TimeIntervalAbsValue(timeinterval) ! !REQUIREMENTS: ! TMG1.5.8 !EOP - CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalAbsValue arg1' ) ESMF_TimeIntervalAbsValue = timeinterval !$$$here... move implementation into BaseTime ESMF_TimeIntervalAbsValue%basetime%S = & abs(ESMF_TimeIntervalAbsValue%basetime%S) ESMF_TimeIntervalAbsValue%basetime%Sn = & abs(ESMF_TimeIntervalAbsValue%basetime%Sn ) + ! + ESMF_TimeIntervalAbsValue%MM = & + abs(ESMF_TimeIntervalAbsValue%MM) + ESMF_TimeIntervalAbsValue%YR = & + abs(ESMF_TimeIntervalAbsValue%YR) end function ESMF_TimeIntervalAbsValue @@ -724,14 +888,17 @@ function ESMF_TimeIntervalNegAbsValue(timeinterval) ! !REQUIREMENTS: ! TMG1.5.8 !EOP - CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalNegAbsValue arg1' ) - ESMF_TimeIntervalNegAbsValue = timeinterval !$$$here... move implementation into BaseTime ESMF_TimeIntervalNegAbsValue%basetime%S = & -abs(ESMF_TimeIntervalNegAbsValue%basetime%S) ESMF_TimeIntervalNegAbsValue%basetime%Sn = & -abs(ESMF_TimeIntervalNegAbsValue%basetime%Sn ) + ! + ESMF_TimeIntervalNegAbsValue%MM = & + -abs(ESMF_TimeIntervalNegAbsValue%MM ) + ESMF_TimeIntervalNegAbsValue%YR = & + -abs(ESMF_TimeIntervalNegAbsValue%YR ) end function ESMF_TimeIntervalNegAbsValue @@ -744,7 +911,6 @@ end function ESMF_TimeIntervalNegAbsValue ! !------------------------------------------------------------------------------ -!!!!!!!!!!!!!!!!!! added jm 20051012 ! new WRF-specific function, Divide two time intervals and return the whole integer, without remainder function ESMF_TimeIntervalDIVQuot(timeinterval1, timeinterval2) @@ -782,11 +948,11 @@ function ESMF_TimeIntervalDIVQuot(timeinterval1, timeinterval2) i2 = timeinterval2 isgn = 1 if ( i1 .LT. zero ) then - i1 = ESMF_TimeIntervalProdI(i1, -1) + i1 = WRFADDITION_TimeIntervalProdI(i1, -1) isgn = -isgn endif if ( i2 .LT. zero ) then - i2 = ESMF_TimeIntervalProdI(i2, -1) + i2 = WRFADDITION_TimeIntervalProdI(i2, -1) isgn = -isgn endif ! repeated subtraction @@ -800,9 +966,53 @@ function ESMF_TimeIntervalDIVQuot(timeinterval1, timeinterval2) ESMF_TimeIntervalDIVQuot = retval end function ESMF_TimeIntervalDIVQuot -!!!!!!!!!!!!!!!!!! +! added by jhe +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: WRFADDITION_TimeIntervalProdI - Multiply a time interval by an +! integer + +! !INTERFACE: + function WRFADDITION_TimeIntervalProdI(timeinterval, multiplier) + +! !RETURN VALUE: + type(ESMF_TimeInterval) :: WRFADDITION_TimeIntervalProdI + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + integer, intent(in) :: multiplier +! !LOCAL: + integer :: rc + +! !DESCRIPTION: +! Multiply a {\tt ESMF\_TimeInterval} by an integer, return product +! as a +! {\tt ESMF\_TimeInterval} +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The multiplicand +! \item[mutliplier] +! Integer multiplier +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.7, TMG7.2 +!EOP + CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdICarg1') + CALL ESMF_TimeIntervalSet( WRFADDITION_TimeIntervalProdI, rc=rc ) +!$$$move this into overloaded operator(*) in BaseTime + WRFADDITION_TimeIntervalProdI%basetime%S = & + timeinterval%basetime%S * INT( multiplier, ESMF_KIND_I8 ) + WRFADDITION_TimeIntervalProdI%basetime%Sn = & + timeinterval%basetime%Sn * INT( multiplier, ESMF_KIND_I8 ) + ! Don't multiply Sd + WRFADDITION_TimeIntervalProdI%basetime%Sd = timeinterval%basetime%Sd + CALL normalize_timeint( WRFADDITION_TimeIntervalProdI ) + end function WRFADDITION_TimeIntervalProdI !------------------------------------------------------------------------------ !BOP @@ -846,8 +1056,7 @@ function ESMF_TimeIntervalQuotI(timeinterval, divisor) ESMF_TimeIntervalQuotI = timeinterval !PRINT *,'DEBUG ESMF_TimeIntervalQuotI() B: S,Sn,Sd = ', & ! ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd - ESMF_TimeIntervalQuotI%basetime = & - timeinterval%basetime / divisor + ESMF_TimeIntervalQuotI%basetime = timeinterval%basetime / divisor !PRINT *,'DEBUG ESMF_TimeIntervalQuotI() C: S,Sn,Sd = ', & ! ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd @@ -888,7 +1097,8 @@ function ESMF_TimeIntervalProdI(timeinterval, multiplier) ! !REQUIREMENTS: ! TMG1.5.7, TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdI arg1' ) + CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdI arg1', & + relative_interval=.true. ) CALL ESMF_TimeIntervalSet( ESMF_TimeIntervalProdI, rc=rc ) !$$$move this into overloaded operator(*) in BaseTime @@ -898,6 +1108,8 @@ function ESMF_TimeIntervalProdI(timeinterval, multiplier) timeinterval%basetime%Sn * INT( multiplier, ESMF_KIND_I8 ) ! Don't multiply Sd ESMF_TimeIntervalProdI%basetime%Sd = timeinterval%basetime%Sd + ESMF_TimeIntervalProdI%MM = timeinterval%MM * multiplier + ESMF_TimeIntervalProdI%YR = timeinterval%YR * multiplier CALL normalize_timeint( ESMF_TimeIntervalProdI ) end function ESMF_TimeIntervalProdI @@ -938,12 +1150,18 @@ function ESMF_TimeIntervalSum(timeinterval1, timeinterval2) ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, ! TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalSum arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalSum arg2' ) + CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalSum arg1', & + relative_interval=.true. ) + CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalSum arg2', & + relative_interval=.true. ) ESMF_TimeIntervalSum = timeinterval1 ESMF_TimeIntervalSum%basetime = ESMF_TimeIntervalSum%basetime + & timeinterval2%basetime + ESMF_TimeIntervalSum%MM = ESMF_TimeIntervalSum%MM + & + timeinterval2%MM + ESMF_TimeIntervalSum%YR = ESMF_TimeIntervalSum%YR + & + timeinterval2%YR CALL normalize_timeint( ESMF_TimeIntervalSum ) @@ -981,12 +1199,18 @@ function ESMF_TimeIntervalDiff(timeinterval1, timeinterval2) ! !REQUIREMENTS: ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalDiff arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalDiff arg2' ) + CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalDiff arg1', & + relative_interval=.true. ) + CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalDiff arg2', & + relative_interval=.true. ) ESMF_TimeIntervalDiff = timeinterval1 ESMF_TimeIntervalDiff%basetime = ESMF_TimeIntervalDiff%basetime - & timeinterval2%basetime + ESMF_TimeIntervalDiff%MM = ESMF_TimeIntervalDiff%MM - & + timeinterval2%MM + ESMF_TimeIntervalDiff%YR = ESMF_TimeIntervalDiff%YR - & + timeinterval2%YR CALL normalize_timeint( ESMF_TimeIntervalDiff ) end function ESMF_TimeIntervalDiff @@ -1021,12 +1245,11 @@ function ESMF_TimeIntervalEQ(timeinterval1, timeinterval2) ! !REQUIREMENTS: ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalEQ arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalEQ arg2' ) -!$$$here... move all this out of Meat.F90 ? - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeIntEQ(timeinterval1, timeinterval2, ESMF_TimeIntervalEQ) + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalEQ = (res .EQ. 0) end function ESMF_TimeIntervalEQ @@ -1060,11 +1283,11 @@ function ESMF_TimeIntervalNE(timeinterval1, timeinterval2) ! !REQUIREMENTS: ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalNE arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalNE arg2' ) - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeIntNE(timeinterval1, timeinterval2, ESMF_TimeIntervalNE) + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalNE = (res .NE. 0) end function ESMF_TimeIntervalNE @@ -1098,11 +1321,11 @@ function ESMF_TimeIntervalLT(timeinterval1, timeinterval2) ! !REQUIREMENTS: ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalLT arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalLT arg2' ) - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeIntLT(timeinterval1, timeinterval2, ESMF_TimeIntervalLT) + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalLT = (res .LT. 0) end function ESMF_TimeIntervalLT @@ -1136,11 +1359,11 @@ function ESMF_TimeIntervalGT(timeinterval1, timeinterval2) ! !REQUIREMENTS: ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalGT arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalGT arg2' ) - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeIntGT(timeinterval1, timeinterval2, ESMF_TimeIntervalGT) + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalGT = (res .GT. 0) end function ESMF_TimeIntervalGT @@ -1175,11 +1398,11 @@ function ESMF_TimeIntervalLE(timeinterval1, timeinterval2) ! !REQUIREMENTS: ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalLE arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalLE arg2' ) - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeIntLE(timeinterval1, timeinterval2, ESMF_TimeIntervalLE) + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalLE = (res .LE. 0) end function ESMF_TimeIntervalLE @@ -1213,14 +1436,13 @@ function ESMF_TimeIntervalGE(timeinterval1, timeinterval2) ! !REQUIREMENTS: ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalGE arg1' ) - CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalGE arg2' ) - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeIntGE(timeinterval1, timeinterval2, ESMF_TimeIntervalGE) + INTEGER :: res - end function ESMF_TimeIntervalGE + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalGE = (res .GE. 0) + end function ESMF_TimeIntervalGE !------------------------------------------------------------------------------ !BOP @@ -1263,6 +1485,204 @@ function ESMF_TimeIntervalIsPositive(timeinterval) zerotimeint ) end function ESMF_TimeIntervalIsPositive - end module ESMF_TimeIntervalMod +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalPrint - Print out a time interval's properties + +! !INTERFACE: + subroutine ESMF_TimeIntervalPrint(timeinterval, opts, rc) + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + character (len=*), intent(in), optional :: opts + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! To support testing/debugging, print out an {\tt ESMF\_TimeInterval}'s +! properties. +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! Time interval to print out +! \item[{[opts]}] +! Print options +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + INTEGER :: ierr + + ierr = ESMF_SUCCESS + call print_a_timeinterval( timeinterval ) + IF ( PRESENT(rc) ) rc = ierr + + end subroutine ESMF_TimeIntervalPrint + +!------------------------------------------------------------------------------ + +! Exits with error message if timeInt is not normalized. +SUBROUTINE timeintchecknormalized( timeInt, msgstr, relative_interval ) + IMPLICIT NONE + TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt + CHARACTER(LEN=*), INTENT(IN) :: msgstr + LOGICAL, INTENT(IN), optional :: relative_interval ! If relative intervals are ok or not + ! locals + CHARACTER(LEN=256) :: outstr + LOGICAL :: non_relative + + IF ( .NOT. PRESENT( relative_interval ) )THEN + non_relative = .true. + ELSE + IF ( relative_interval )THEN + non_relative = .false. + ELSE + non_relative = .true. + END IF + END IF + IF ( non_relative )THEN + IF ( ( timeInt%YR /= 0 ) .OR. & + ( timeInt%MM /= 0 ) ) THEN + outstr = 'un-normalized TimeInterval not allowed: '//TRIM(msgstr) + CALL wrf_error_fatal( outstr ) + ENDIF + ELSE + IF ( ( timeInt%YR /= 0 ) .OR. & + ( timeInt%MM < -MONTHS_PER_YEAR) .OR. ( timeInt%MM > MONTHS_PER_YEAR ) ) THEN +! tcraig, don't require normalize TimeInterval for relative diffs +! outstr = 'un-normalized TimeInterval not allowed: '//TRIM(msgstr) +! CALL wrf_error_fatal( outstr ) + ENDIF + END IF +END SUBROUTINE timeintchecknormalized + +!============================================================================== +SUBROUTINE print_a_timeinterval( time ) + IMPLICIT NONE + type(ESMF_TimeInterval) time + character*128 :: s + integer rc + CALL ESMFold_TimeIntervalGetString( time, s, rc ) + write(6,*)'Print a time interval|',time%yr, time%mm, time%basetime%s, time%starttime_set, time%starttime%calendar%type%caltype + write(6,*)'Print a time interval|',TRIM(s),'|' + return +END SUBROUTINE print_a_timeinterval + +!============================================================================== + +SUBROUTINE timeintcmp(timeint1in, timeint2in, retval ) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: retval +! +! !ARGUMENTS: + TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1in + TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2in + + TYPE(ESMF_TimeInterval) :: timeint1 + TYPE(ESMF_TimeInterval) :: timeint2 + + timeint1 = timeint1in + timeint2 = timeint2in + call normalize_timeint(timeint1) + call normalize_timeint(timeint2) + + IF ( (timeint1%MM /= timeint2%MM) .and. (timeint1%YR /= timeint2%YR) )THEN + CALL wrf_error_fatal( & + 'timeintcmp: Can not compare two intervals with different months and years' ) + END IF + if (timeint1%YR .gt. timeint2%YR) then + retval = 1 + elseif (timeint1%YR .lt. timeint2%YR) then + retval = -1 + else + if (timeint1%MM .gt. timeint2%MM) then + retval = 1 + elseif (timeint1%MM .lt. timeint2%MM) then + retval = 1 + else + CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, & + timeint1%basetime%Sd, & + timeint2%basetime%S, timeint2%basetime%Sn, & + timeint2%basetime%Sd, retval ) + endif + endif + +END SUBROUTINE timeintcmp + +!============================================================================== + +SUBROUTINE normalize_timeint( timeInt ) + IMPLICIT NONE + TYPE(ESMF_TimeInterval), INTENT(INOUT) :: timeInt + INTEGER :: mpyi4 + + ! normalize basetime + ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match + ! YR and MM are ignored + + CALL normalize_basetime( timeInt%basetime ) + + ! Rollover months to years + + mpyi4 = MONTHS_PER_YEAR + IF ( abs(timeInt%MM) .GE. MONTHS_PER_YEAR ) THEN + timeInt%YR = timeInt%YR + timeInt%MM/MONTHS_PER_YEAR + timeInt%MM = mod(timeInt%MM,mpyi4) + ENDIF + + ! make sure yr and mm have same sign + + IF (timeInt%YR * timeInt%MM < 0) then + if (timeInt%YR > 0) then + timeInt%MM = timeInt%MM + MONTHS_PER_YEAR + timeInt%YR = timeInt%YR - 1 + endif + if (timeInt%YR < 0) then + timeInt%MM = timeInt%MM - MONTHS_PER_YEAR + timeInt%YR = timeInt%YR + 1 + endif + endif + +END SUBROUTINE normalize_timeint + +!============================================================================== + +integer FUNCTION signnormtimeint ( timeInt ) + ! Compute the sign of a time interval. + ! YR and MM fields are *IGNORED*. + ! returns 1, 0, or -1 or exits if timeInt fields have inconsistent signs. + IMPLICIT NONE + TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt + LOGICAL :: positive, negative + + positive = .FALSE. + negative = .FALSE. + signnormtimeint = 0 + ! Note that Sd is required to be non-negative. This is enforced in + ! normalize_timeint(). + ! Note that Sn is required to be zero when Sd is zero. This is enforced + ! in normalize_timeint(). + IF ( ( timeInt%basetime%S > 0 ) .OR. & + ( timeInt%basetime%Sn > 0 ) ) THEN + positive = .TRUE. + ENDIF + IF ( ( timeInt%basetime%S < 0 ) .OR. & + ( timeInt%basetime%Sn < 0 ) ) THEN + negative = .TRUE. + ENDIF + IF ( positive .AND. negative ) THEN + CALL wrf_error_fatal( & + 'signnormtimeint: signs of fields cannot be mixed' ) + ELSE IF ( positive ) THEN + signnormtimeint = 1 + ELSE IF ( negative ) THEN + signnormtimeint = -1 + ENDIF +END FUNCTION signnormtimeint +!============================================================================== +end module ESMF_TimeIntervalMod diff --git a/src/external/esmf_time_f90/ESMF_TimeMgr.inc b/src/external/esmf_time_f90/ESMF_TimeMgr.inc index 2180aa4f4e..e41a1f8514 100644 --- a/src/external/esmf_time_f90/ESMF_TimeMgr.inc +++ b/src/external/esmf_time_f90/ESMF_TimeMgr.inc @@ -1,4 +1,5 @@ #if 0 +$Id$ Earth System Modeling Framework Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -6,7 +7,7 @@ Massachusetts Institute of Technology, Geophysical Fluid Dynamics Laboratory, University of Michigan, National Centers for Environmental Prediction, Los Alamos National Laboratory, Argonne National Laboratory, NASA Goddard Space Flight Center. -Licensed under the University of Illinois-NCSA license. +Licensed under the GPL. Do not have C++ or F90 style comments in here because this file is processed by both C++ and F90 compilers. @@ -34,28 +35,11 @@ by both C++ and F90 compilers. #define SECONDS_PER_HOUR 3600_ESMF_KIND_I8 #define SECONDS_PER_MINUTE 60_ESMF_KIND_I8 #define HOURS_PER_DAY 24_ESMF_KIND_I8 +#define MONTHS_PER_YEAR 12_ESMF_KIND_I8 ! Note that MAX_ALARMS must match MAX_WRF_ALARMS defined in ! ../../frame/module_domain.F !!! Eliminate this dependence with ! grow-as-you-go AlarmList in ESMF_Clock... -#define MAX_HISTORY 10 -#define MAX_ALARMS (2*(MAX_HISTORY)+10) - -! TBH: TODO: Hook this into the WRF build so WRF can use either "no-leap" or -! TBH: Gregorian calendar. Now WRF is hard-wired to use Gregorian. -!#undef NO_LEAP_CALENDAR -!#ifdef COUP_CSM -!#define NO_LEAP_CALENDAR -!#endif - -! TBH: When NO_DT_COMPONENT_INIT is set, code that uses F95 compile-time -! TBH: initialization of components of derived types is not included. -! TBH: Some older compilers like PGI 5.x do not support this F95 -! TBH: feature. -!#ifdef NO_LEAP_CALENDAR -!#undef NO_DT_COMPONENT_INIT -!#else -!#define NO_DT_COMPONENT_INIT -!#endif +#define MAX_ALARMS 60 #endif diff --git a/src/external/esmf_time_f90/ESMF_Time.F90 b/src/external/esmf_time_f90/ESMF_TimeMod.F90 similarity index 64% rename from src/external/esmf_time_f90/ESMF_Time.F90 rename to src/external/esmf_time_f90/ESMF_TimeMod.F90 index 1b94270a0e..c165ebd4a1 100644 --- a/src/external/esmf_time_f90/ESMF_Time.F90 +++ b/src/external/esmf_time_f90/ESMF_TimeMod.F90 @@ -1,3 +1,4 @@ +! $Id$ ! ! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, @@ -5,7 +6,7 @@ ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. -! Licensed under the University of Illinois-NCSA license. +! Licensed under the GPL. ! !============================================================================== ! @@ -43,6 +44,8 @@ module ESMF_TimeMod ! associated derived types use ESMF_TimeIntervalMod use ESMF_CalendarMod + use ESMF_ShrTimeMod, only : ESMF_Time +! added by Jhe use ESMF_Stubs implicit none @@ -56,12 +59,15 @@ module ESMF_TimeMod ! ! F90 class type to match C++ Time class in size only; ! ! all dereferencing within class is performed by C++ implementation - type ESMF_Time - type(ESMF_BaseTime) :: basetime ! inherit base class - ! time instant is expressed as year + basetime - integer :: YR - type(ESMF_Calendar), pointer :: calendar ! associated calendar - end type +! move to ESMF_ShrTimeMod +! type ESMF_Time +! type(ESMF_BaseTime) :: basetime ! inherit base class +! ! time instant is expressed as year + basetime +! integer :: YR +! type(ESMF_Calendar), pointer :: calendar ! associated calendar +! end type +!------------------------------------------------------------------------------ +! !PUBLIC DATA: !------------------------------------------------------------------------------ ! !PUBLIC TYPES: @@ -71,10 +77,12 @@ module ESMF_TimeMod ! !PUBLIC MEMBER FUNCTIONS: public ESMF_TimeGet public ESMF_TimeSet + public ESMF_TimePrint ! Required inherited and overridden ESMF_Base class methods public ESMF_TimeCopy + public ESMF_SetYearWidth ! !PRIVATE MEMBER FUNCTIONS: @@ -83,18 +91,12 @@ module ESMF_TimeMod ! Inherited and overloaded from ESMF_BaseTime - ! NOTE: ESMF_TimeInc, ESMF_TimeDec, ESMF_TimeDiff, ESMF_TimeEQ, - ! ESMF_TimeNE, ESMF_TimeLT, ESMF_TimeGT, ESMF_TimeLE, and - ! ESMF_TimeGE are PUBLIC only to work around bugs in the - ! PGI 5.1-x compilers. They should all be PRIVATE. - public operator(+) public ESMF_TimeInc public operator(-) - public ESMF_TimeDec - public ESMF_TimeDec2 - public ESMF_TimeDiff + private ESMF_TimeDec + private ESMF_TimeDiff public operator(.EQ.) public ESMF_TimeEQ @@ -116,6 +118,13 @@ module ESMF_TimeMod !EOPI +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + + integer :: yearWidth = 4 + !============================================================================== ! ! INTERFACE BLOCKS @@ -282,23 +291,25 @@ module ESMF_TimeMod contains !============================================================================== -! -! Generic Get/Set routines which use F90 optional arguments -! !------------------------------------------------------------------------------ !BOP ! !IROUTINE: ESMF_TimeGet - Get value in user-specified units ! !INTERFACE: - subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & - US, NS, d_, h_, m_, s_, ms_, us_, ns_, Sn, Sd, & +! subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & +! US, NS, d_, h_, m_, s_, ms_, us_, ns_, Sn, Sd, & +! dayOfYear, dayOfYear_r8, dayOfYear_intvl, & +! timeString, rc) + +recursive subroutine ESMF_TimeGet(time, YY, MM, DD, D, Dl, H, M, S, MS, & + Sn, Sd, & dayOfYear, dayOfYear_r8, dayOfYear_intvl, & timeString, rc) ! !ARGUMENTS: type(ESMF_Time), intent(in) :: time integer, intent(out), optional :: YY - integer(ESMF_KIND_I8), intent(out), optional :: YRl +! integer(ESMF_KIND_I8), intent(out), optional :: YRl integer, intent(out), optional :: MM integer, intent(out), optional :: DD integer, intent(out), optional :: D @@ -306,29 +317,25 @@ subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & integer, intent(out), optional :: H integer, intent(out), optional :: M integer, intent(out), optional :: S - integer(ESMF_KIND_I8), intent(out), optional :: Sl +! integer(ESMF_KIND_I8), intent(out), optional :: Sl integer, intent(out), optional :: MS - integer, intent(out), optional :: US - integer, intent(out), optional :: NS - double precision, intent(out), optional :: d_ - double precision, intent(out), optional :: h_ - double precision, intent(out), optional :: m_ - double precision, intent(out), optional :: s_ - double precision, intent(out), optional :: ms_ - double precision, intent(out), optional :: us_ - double precision, intent(out), optional :: ns_ +! integer, intent(out), optional :: US +! integer, intent(out), optional :: NS +! double precision, intent(out), optional :: d_ +! double precision, intent(out), optional :: h_ +! double precision, intent(out), optional :: m_ +! double precision, intent(out), optional :: s_ +! double precision, intent(out), optional :: ms_ +! double precision, intent(out), optional :: us_ +! double precision, intent(out), optional :: ns_ integer, intent(out), optional :: Sn integer, intent(out), optional :: Sd integer, intent(out), optional :: dayOfYear - ! dayOfYear_r8 = 1.0 at 0Z on 1 January, 1.5 at 12Z on - ! 1 January, etc. real(ESMF_KIND_R8), intent(out), optional :: dayOfYear_r8 character (len=*), intent(out), optional :: timeString type(ESMF_TimeInterval), intent(out), optional :: dayOfYear_intvl integer, intent(out), optional :: rc - type(ESMF_TimeInterval) :: day_step - integer :: ierr ! !DESCRIPTION: ! Get the value of the {\tt ESMF\_Time} in units specified by the user @@ -396,9 +403,13 @@ subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & ! !REQUIREMENTS: ! TMG2.1, TMG2.5.1, TMG2.5.6 !EOP + type(ESMF_TimeInterval) :: day_step + integer :: ierr TYPE(ESMF_Time) :: begofyear + TYPE(ESMF_TimeInterval) :: difftobegofyear INTEGER :: year, month, dayofmonth, hour, minute, second - REAL(ESMF_KIND_R8) :: rsec + INTEGER :: i + INTEGER(ESMF_KIND_I8) :: cnt ierr = ESMF_SUCCESS @@ -411,9 +422,30 @@ subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & IF ( PRESENT( DD ) ) THEN CALL timegetdayofmonth( time, DD ) ENDIF + + if (present(d) .or. present(dl)) then + cnt = 0 + do i = 0,time%yr-1 + cnt = cnt + ndaysinyear(i,time%calendar%type) + enddo + do i = time%yr,-1 + cnt = cnt - ndaysinyear(i,time%calendar%type) + enddo + call timegetmonth(time,month) + do i = 1,month-1 + cnt = cnt + ndaysinmonth(time%yr,i,time%calendar%type) + enddo + call timegetdayofmonth( time, dayofmonth) + cnt = cnt + dayofmonth + if (present(d)) then + d = cnt + endif + if (present(dl)) then + dl = cnt + endif + endif ! -!$$$ Push HMS down into ESMF_BaseTime from EVERYWHERE -!$$$ and THEN add ESMF scaling behavior when other args are present... +!$$$ push HMS down into ESMF_BaseTime IF ( PRESENT( H ) ) THEN H = mod( time%basetime%S, SECONDS_PER_DAY ) / SECONDS_PER_HOUR ENDIF @@ -423,8 +455,7 @@ subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & IF ( PRESENT( S ) ) THEN S = mod( time%basetime%S, SECONDS_PER_MINUTE ) ENDIF - ! TBH: HACK to allow DD and S to behave as in ESMF 2.1.0+ when - ! TBH: both are present and H and M are not. + IF ( PRESENT( S ) .AND. PRESENT( DD ) ) THEN IF ( ( .NOT. PRESENT( H ) ) .AND. ( .NOT. PRESENT( M ) ) ) THEN S = mod( time%basetime%S, SECONDS_PER_DAY ) @@ -444,18 +475,6 @@ subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & IF ( PRESENT( dayOfYear ) ) THEN CALL ESMF_TimeGetDayOfYear( time, dayOfYear, rc=ierr ) ENDIF - IF ( PRESENT( dayOfYear_r8 ) ) THEN - ! 64-bit IEEE 754 has 52-bit mantisssa -- only need 25 bits to hold - ! number of seconds in a year... - rsec = REAL( time%basetime%S, ESMF_KIND_R8 ) - IF ( time%basetime%Sd /= 0 ) THEN - rsec = rsec + ( REAL( time%basetime%Sn, ESMF_KIND_R8 ) / & - REAL( time%basetime%Sd, ESMF_KIND_R8 ) ) - ENDIF - dayOfYear_r8 = rsec / REAL( SECONDS_PER_DAY, ESMF_KIND_R8 ) - ! start at 1 - dayOfYear_r8 = dayOfYear_r8 + 1.0_ESMF_KIND_R8 - ENDIF IF ( PRESENT( timeString ) ) THEN ! This duplication for YMD is an optimization that avoids calling ! timegetmonth() and timegetdayofmonth() when it is not needed. @@ -470,6 +489,16 @@ subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & hour, minute, second, timeString ) ENDIF IF ( PRESENT( dayOfYear_intvl ) ) THEN + year = time%YR + CALL ESMF_TimeSet( begofyear, yy=year, mm=1, dd=1, s=0, & + calendar=time%calendar, rc=ierr ) + IF ( ierr == ESMF_FAILURE)THEN + rc = ierr + RETURN + END IF + dayOfYear_intvl = time - begofyear + ENDIF + IF ( PRESENT( dayOfYear_r8) ) THEN year = time%YR CALL ESMF_TimeSet( begofyear, yy=year, mm=1, dd=1, s=0, & calendar=time%calendar, rc=ierr ) @@ -478,7 +507,16 @@ subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & RETURN END IF CALL ESMF_TimeIntervalSet( day_step, d=1, s=0, rc=ierr ) - dayOfYear_intvl = time - begofyear + day_step + IF ( ierr == ESMF_FAILURE)THEN + rc = ierr + RETURN + END IF + difftobegofyear = time - begofyear + day_step + CALL ESMF_TimeIntervalGet( difftobegofyear, d_r8=dayOfYear_r8, rc=ierr ) + IF ( ierr == ESMF_FAILURE)THEN + rc = ierr + RETURN + END IF ENDIF IF ( PRESENT( rc ) ) THEN @@ -492,14 +530,18 @@ end subroutine ESMF_TimeGet ! !IROUTINE: ESMF_TimeSet - Initialize via user-specified unit set ! !INTERFACE: - subroutine ESMF_TimeSet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, & - MS, US, NS, d_, h_, m_, s_, ms_, us_, ns_, & - Sn, Sd, calendar, rc) +! subroutine ESMF_TimeSet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, & +! MS, US, NS, d_, h_, m_, s_, ms_, us_, ns_, & +! Sn, Sd, calendar, calkindflag, rc) + + subroutine ESMF_TimeSet(time, YY, MM, DD, D, Dl, H, M, S, & + MS, & + Sn, Sd, calendar, calkindflag, rc) ! !ARGUMENTS: type(ESMF_Time), intent(inout) :: time integer, intent(in), optional :: YY - integer(ESMF_KIND_I8), intent(in), optional :: YRl +! integer(ESMF_KIND_I8), intent(in), optional :: YRl integer, intent(in), optional :: MM integer, intent(in), optional :: DD integer, intent(in), optional :: D @@ -507,23 +549,26 @@ subroutine ESMF_TimeSet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, & integer, intent(in), optional :: H integer, intent(in), optional :: M integer, intent(in), optional :: S - integer(ESMF_KIND_I8), intent(in), optional :: Sl +! integer(ESMF_KIND_I8), intent(in), optional :: Sl integer, intent(in), optional :: MS - integer, intent(in), optional :: US - integer, intent(in), optional :: NS - double precision, intent(in), optional :: d_ - double precision, intent(in), optional :: h_ - double precision, intent(in), optional :: m_ - double precision, intent(in), optional :: s_ - double precision, intent(in), optional :: ms_ - double precision, intent(in), optional :: us_ - double precision, intent(in), optional :: ns_ +! integer, intent(in), optional :: US +! integer, intent(in), optional :: NS +! double precision, intent(in), optional :: d_ +! double precision, intent(in), optional :: h_ +! double precision, intent(in), optional :: m_ +! double precision, intent(in), optional :: s_ +! double precision, intent(in), optional :: ms_ +! double precision, intent(in), optional :: us_ +! double precision, intent(in), optional :: ns_ integer, intent(in), optional :: Sn integer, intent(in), optional :: Sd type(ESMF_Calendar), intent(in), target, optional :: calendar + type(ESMF_CalKind_Flag), intent(in), optional :: calkindflag integer, intent(out), optional :: rc + ! locals INTEGER :: ierr + logical :: dset ! !DESCRIPTION: ! Initializes a {\tt ESMF\_Time} with a set of user-specified units @@ -597,28 +642,89 @@ subroutine ESMF_TimeSet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, & !EOP ! PRINT *,'DEBUG: BEGIN ESMF_TimeSet()' !$$$ push this down into ESMF_BaseTime constructor + + IF ( PRESENT( rc ) ) then + rc = ESMF_FAILURE + ENDIF + + time%YR = 0 time%basetime%S = 0 time%basetime%Sn = 0 time%basetime%Sd = 0 - IF ( PRESENT( rc ) ) rc = ESMF_FAILURE - time%YR = 0 + IF ( PRESENT(calendar) )THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): using passed-in calendar' + IF ( .not. ESMF_CalendarInitialized( calendar ) )THEN + call wrf_error_fatal( "Error:: ESMF_CalendarCreate not "// & + "called on input Calendar") + END IF +! call flush(6) +! write(6,*) 'tcx1 ESMF_TimeSet point to calendar' +! call flush(6) + time%Calendar => calendar + ELSE +! PRINT *,'DEBUG: ESMF_TimeSet(): using default calendar' +! for the sake of WRF, check ESMF_IsInitialized, revised by Juanxiong He + IF ( .not. ESMF_IsInitialized() )THEN + call wrf_error_fatal( "Error:: ESMF_Initialize not called") + END IF +! IF ( .not. ESMF_CalendarInitialized( defaultCal ) )THEN +! call wrf_error_fatal( "Error:: ESMF_Initialize not called") +! END IF + if (present(calkindflag)) then +! write(6,*) 'tcx2 ESMF_TimeSet point to calendarkindflag',calkindflag%caltype +! call flush(6) + if (calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype) then + time%Calendar => gregorianCal + elseif (calkindflag%caltype == ESMF_CALKIND_NOLEAP%caltype) then + time%Calendar => noleapCal + else + call wrf_error_fatal( "Error:: ESMF_TimeSet invalid calkindflag") + endif + else +! write(6,*) 'tcx3 ESMF_TimeSet point to defaultcal' +! call flush(6) + time%Calendar => defaultCal + endif + END IF +! write(6,*) 'tcxn ESMF_TimeSet ',ESMF_CALKIND_NOLEAP%caltype +! call flush(6) +! write(6,*) 'tcxg ESMF_TimeSet ',ESMF_CALKIND_GREGORIAN%caltype +! call flush(6) +! write(6,*) 'tcxt ESMF_TimeSet ',time%calendar%type%caltype +! call flush(6) + + dset = .false. + if (present(D)) then + if (present(Dl)) CALL wrf_error_fatal( 'ESMF_TimeSet: D and Dl not both valid') + time%basetime%s = SECONDS_PER_DAY * INT(D-1,ESMF_KIND_I8) + dset=.true. + elseif (present(Dl)) then + time%basetime%s = SECONDS_PER_DAY * Dl-1_ESMF_KIND_I8 + dset=.true. + endif + IF ( PRESENT( YY ) ) THEN ! PRINT *,'DEBUG: ESMF_TimeSet(): YY = ',YY + if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') time%YR = YY ENDIF IF ( PRESENT( MM ) ) THEN + if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') ! PRINT *,'DEBUG: ESMF_TimeSet(): MM = ',MM CALL timeaddmonths( time, MM, ierr ) IF ( ierr == ESMF_FAILURE ) THEN IF ( PRESENT( rc ) ) THEN rc = ESMF_FAILURE RETURN + ELSE + CALL wrf_error_fatal( 'ESMF_TimeSet: MM out of range' ) ENDIF ENDIF ! PRINT *,'DEBUG: ESMF_TimeSet(): back from timeaddmonths' ENDIF IF ( PRESENT( DD ) ) THEN + if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') !$$$ no check for DD in range of days of month MM yet !$$$ Must separate D and DD for correct interface! ! PRINT *,'DEBUG: ESMF_TimeSet(): DD = ',DD @@ -663,26 +769,6 @@ subroutine ESMF_TimeSet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, & time%basetime%Sn = Sn ENDIF ENDIF - IF ( PRESENT(calendar) )THEN -! PRINT *,'DEBUG: ESMF_TimeSet(): using passed-in calendar' -! Note that the ugly hack of wrapping the call to ESMF_CalendarInitialized() -! inside this #ifdef is due to lack of support for compile-time initialization -! of components of Fortran derived types. Some older compilers like PGI 5.1-x -! do not support this F95 feature. In this case we only lose a safety check. -#ifndef NO_DT_COMPONENT_INIT - IF ( .not. ESMF_CalendarInitialized( calendar ) )THEN - call wrf_error_fatal( "Error:: ESMF_CalendarCreate not "// & - "called on input Calendar") - END IF -#endif - time%Calendar => calendar - ELSE -! PRINT *,'DEBUG: ESMF_TimeSet(): using default calendar' - IF ( .not. ESMF_IsInitialized() )THEN - call wrf_error_fatal( "Error:: ESMF_Initialize not called") - END IF - time%Calendar => defaultCal - END IF ! PRINT *,'DEBUG: ESMF_TimeSet(): calling normalize_time()' !$$$DEBUG @@ -722,6 +808,7 @@ subroutine ESMFold_TimeGetString( year, month, dayofmonth, & integer, intent(in) :: minute integer, intent(in) :: second character*(*), intent(out) :: TimeString + character*(256) :: TimeFormatString ! !DESCRIPTION: ! Convert {\tt ESMF\_Time}'s value into ISO 8601 format YYYY-MM-DDThh:mm:ss ! @@ -748,13 +835,8 @@ subroutine ESMFold_TimeGetString( year, month, dayofmonth, & !$$$here... add negative sign for YR<0 !$$$here... add Sn, Sd ?? -#ifdef PLANET - write(TimeString,FMT="(I4.4,'-',I5.5,'_',I2.2,':',I2.2,':',I2.2)") & - year,dayofmonth,hour,minute,second -#else - write(TimeString,FMT="(I4.4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2)") & - year,month,dayofmonth,hour,minute,second -#endif + write(TimeFormatString,FMT="(A,I4.4,A,I4.4,A)") "(I", yearWidth, ".", yearWidth, "'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2)" + write(TimeString,FMT=TimeFormatString) year,month,dayofmonth,hour,minute,second end subroutine ESMFold_TimeGetString @@ -798,7 +880,7 @@ end subroutine ESMF_TimeGetDayOfYearInteger ! !IROUTINE: ESMF_TimeInc - Increment time instant with a time interval ! ! !INTERFACE: - function ESMF_TimeInc(time, timeinterval) + function ESMF_TimeInc(time, timeinterval) ! ! !RETURN VALUE: type(ESMF_Time) :: ESMF_TimeInc @@ -807,7 +889,7 @@ function ESMF_TimeInc(time, timeinterval) type(ESMF_Time), intent(in) :: time type(ESMF_TimeInterval), intent(in) :: timeinterval ! !LOCAL: - integer :: rc + INTEGER :: year,month,day,sec,nmon,nyr,mpyi4 ! ! !DESCRIPTION: ! Increment {\tt ESMF\_Time} instant with a {\tt ESMF\_TimeInterval}, @@ -828,30 +910,72 @@ function ESMF_TimeInc(time, timeinterval) ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 !EOP + mpyi4 = MONTHS_PER_YEAR + ! copy ESMF_Time specific properties (e.g. calendar, timezone) + ESMF_TimeInc = time +! write(6,*) 'tcx timeinc1 ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s + CALL normalize_time( ESMF_TimeInc ) - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeSum(time, timeinterval, ESMF_TimeInc) +! write(6,*) 'tcx timeint ',timeinterval%yr,timeinterval%mm,timeinterval%basetime%s + + ! add years and months by manually forcing incremental years then adjusting the day of + ! the month at the end if it's greater than the number of days in the month + ! esmf seems to do exactly this based on testing + + nmon = timeinterval%mm + nyr = timeinterval%yr + if (abs(nmon) > 0 .or. abs(nyr) > 0) then + call ESMF_TimeGet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec) +! write(6,*) 'tcx timeinc mon1 ',year,month,day,sec,nyr,nmon + year = year + nyr + month = month + nmon + do while (month > MONTHS_PER_YEAR) + month = month - mpyi4 + year = year + 1 + enddo + do while (month < 1) + month = month + mpyi4 + year = year - 1 + enddo +! write(6,*) 'tcx timeinc mon2 ',year,month,day,sec + day = min(day,ndaysinmonth(year,month,ESMF_TimeInc%calendar%type)) + call ESMF_TimeSet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec,calkindflag=time%calendar%type) + call ESMF_TimeGet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec) +! write(6,*) 'tcx timeinc mon3 ',nmon,year,month,day,sec + endif + + ! finally add seconds + +! write(6,*) 'tcx timeinc sec ',ESMF_TimeInc%basetime%s,timeinterval%basetime%s + ESMF_TimeInc%basetime = ESMF_TimeInc%basetime + timeinterval%basetime + + ! and normalize + +! write(6,*) 'tcx timeinc2p ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s + + CALL normalize_time( ESMF_TimeInc ) + +! write(6,*) 'tcx timeinc2 ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s + + end function ESMF_TimeInc - end function ESMF_TimeInc -! ! this is added for certain compilers that don't deal with commutativity -! - function ESMF_TimeInc2(timeinterval, time) + + function ESMF_TimeInc2(timeinterval, time) type(ESMF_Time) :: ESMF_TimeInc2 type(ESMF_Time), intent(in) :: time type(ESMF_TimeInterval), intent(in) :: timeinterval ESMF_TimeInc2 = ESMF_TimeInc( time, timeinterval ) - end function ESMF_TimeInc2 -! + end function ESMF_TimeInc2 !------------------------------------------------------------------------------ !BOP ! !IROUTINE: ESMF_TimeDec - Decrement time instant with a time interval ! ! !INTERFACE: - function ESMF_TimeDec(time, timeinterval) + function ESMF_TimeDec(time, timeinterval) ! ! !RETURN VALUE: type(ESMF_Time) :: ESMF_TimeDec @@ -860,8 +984,8 @@ function ESMF_TimeDec(time, timeinterval) type(ESMF_Time), intent(in) :: time type(ESMF_TimeInterval), intent(in) :: timeinterval ! !LOCAL: - integer :: rc -! + TYPE (ESMF_TimeInterval) :: neginterval + ! !DESCRIPTION: ! Decrement {\tt ESMF\_Time} instant with a {\tt ESMF\_TimeInterval}, ! return resulting {\tt ESMF\_Time} instant @@ -882,30 +1006,34 @@ function ESMF_TimeDec(time, timeinterval) ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 !EOP - ! copy ESMF_Time specific properties (e.g. calendar, timezone) ESMF_TimeDec = time - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeDec(time, timeinterval, ESMF_TimeDec) + neginterval = timeinterval +!$$$push this down into a unary negation operator on TimeInterval + neginterval%basetime%S = -neginterval%basetime%S + neginterval%basetime%Sn = -neginterval%basetime%Sn + neginterval%YR = -neginterval%YR + neginterval%MM = -neginterval%MM + ESMF_TimeDec = time + neginterval - end function ESMF_TimeDec + end function ESMF_TimeDec ! ! this is added for certain compilers that don't deal with commutativity ! - function ESMF_TimeDec2(timeinterval, time) + function ESMF_TimeDec2(timeinterval, time) type(ESMF_Time) :: ESMF_TimeDec2 type(ESMF_Time), intent(in) :: time type(ESMF_TimeInterval), intent(in) :: timeinterval ESMF_TimeDec2 = ESMF_TimeDec( time, timeinterval ) - end function ESMF_TimeDec2 + end function ESMF_TimeDec2 ! !------------------------------------------------------------------------------ !BOP ! !IROUTINE: ESMF_TimeDiff - Return the difference between two time instants ! ! !INTERFACE: - function ESMF_TimeDiff(time1, time2) + function ESMF_TimeDiff(time1, time2) ! ! !RETURN VALUE: type(ESMF_TimeInterval) :: ESMF_TimeDiff @@ -914,11 +1042,14 @@ function ESMF_TimeDiff(time1, time2) type(ESMF_Time), intent(in) :: time1 type(ESMF_Time), intent(in) :: time2 ! !LOCAL: + TYPE(ESMF_BaseTime) :: cmptime, zerotime + integer :: yr + integer :: y1,m1,d1,s1,y2,m2,d2,s2 integer :: rc ! !DESCRIPTION: ! Return the {\tt ESMF\_TimeInterval} difference between two -! {\tt ESMF\_Time} instants +! {\tt ESMF\_Time} instants, time1 - time2 ! ! Maps overloaded (-) operator interface function to ! {\tt ESMF\_BaseTime} base class @@ -935,11 +1066,53 @@ function ESMF_TimeDiff(time1, time2) ! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 !EOP - ! call ESMC_BaseTime base class function CALL ESMF_TimeIntervalSet( ESMF_TimeDiff, rc=rc ) - call c_ESMC_BaseTimeDiff(time1, time2, ESMF_TimeDiff) - end function ESMF_TimeDiff + ESMF_TimeDiff%StartTime = time2 + ESMF_TimeDiff%StartTime_set = .true. + +! write(6,*) 'tcx timediff1 ',time2%yr,time2%basetime%s,time2%calendar%type%caltype +! write(6,*) 'tcx timediff2 ',time1%yr,time1%basetime%s,time1%calendar%type%caltype + + call ESMF_TimeGet(time2,yy=y2,mm=m2,dd=d2,s=s2) + call ESMF_TimeGet(time1,yy=y1,mm=m1,dd=d1,s=s1) + + ! Can either be yr/month based diff if diff is only in year and month + ! or absolute seconds if diff in day/seconds as well + + if (d1 == d2 .and. s1 == s2) then +! write(6,*) 'tcx timedifft ym' + ESMF_TimeDiff%YR = y1 - y2 + ESMF_TimeDiff%MM = m1 - m2 + cmptime%S = 0 + cmptime%Sn = 0 + cmptime%Sd = 0 + ESMF_TimeDiff%basetime = cmptime + else +! write(6,*) 'tcx timedifft sec' + ESMF_TimeDiff%YR = 0 + ESMF_TimeDiff%MM = 0 + ESMF_TimeDiff%basetime = time1%basetime - time2%basetime + IF ( time1%YR > time2%YR ) THEN + DO yr = time2%YR, ( time1%YR - 1 ) +! write(6,*) 'tcx timediff3 ',yr,nsecondsinyear(yr,time2%calendar%type) + ESMF_TimeDiff%basetime%S = ESMF_TimeDiff%basetime%S + nsecondsinyear(yr,time2%calendar%type) + ENDDO + ELSE IF ( time2%YR > time1%YR ) THEN + DO yr = time1%YR, ( time2%YR - 1 ) +! write(6,*) 'tcx timediff4 ',yr,nsecondsinyear(yr,time2%calendar%type) + ESMF_TimeDiff%basetime%S = ESMF_TimeDiff%basetime%S - nsecondsinyear(yr,time2%calendar%type) + ENDDO + ENDIF + endif + +! write(6,*) 'tcx timediff5 ',ESMF_TimeDiff%YR, ESMF_TimeDiff%MM, ESMF_TimeDiff%basetime%s + + CALL normalize_timeint( ESMF_TimeDiff ) + +! write(6,*) 'tcx timediff6 ',ESMF_TimeDiff%YR, ESMF_TimeDiff%MM, ESMF_TimeDiff%basetime%s + + end function ESMF_TimeDiff !------------------------------------------------------------------------------ !BOP @@ -972,8 +1145,10 @@ function ESMF_TimeEQ(time1, time2) ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - ! invoke C to C++ entry point for ESMF_BaseTime base class function - call c_ESMC_BaseTimeEQ(time1, time2, ESMF_TimeEQ) + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeEQ = (res .EQ. 0) end function ESMF_TimeEQ @@ -1008,8 +1183,10 @@ function ESMF_TimeNE(time1, time2) ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeNE(time1, time2, ESMF_TimeNE) + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeNE = (res .NE. 0) end function ESMF_TimeNE @@ -1044,8 +1221,10 @@ function ESMF_TimeLT(time1, time2) ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeLT(time1, time2, ESMF_TimeLT) + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeLT = (res .LT. 0) end function ESMF_TimeLT @@ -1080,8 +1259,10 @@ function ESMF_TimeGT(time1, time2) ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeGT(time1, time2, ESMF_TimeGT) + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeGT = (res .GT. 0) end function ESMF_TimeGT @@ -1116,8 +1297,10 @@ function ESMF_TimeLE(time1, time2) ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeLE(time1, time2, ESMF_TimeLE) + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeLE = (res .LE. 0) end function ESMF_TimeLE @@ -1152,8 +1335,10 @@ function ESMF_TimeGE(time1, time2) ! TMG1.5.3, TMG2.4.3, TMG7.2 !EOP - ! call ESMC_BaseTime base class function - call c_ESMC_BaseTimeGE(time1, time2, ESMF_TimeGE) + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeGE = (res .GE. 0) end function ESMF_TimeGE @@ -1182,7 +1367,203 @@ subroutine ESMF_TimeCopy(timeout, timein) timeout%basetime = timein%basetime timeout%YR = timein%YR timeout%Calendar => timein%Calendar +!tcx timeout%Calendar = timein%Calendar +! write(6,*) 'tcxa ESMF_TimeCopy' +! call flush(6) +! write(6,*) 'tcxb ESMF_TimeCopy',timein%calendar%type%caltype +! call flush(6) + timeout%Calendar = ESMF_CalendarCreate(calkindflag=timein%calendar%type) end subroutine ESMF_TimeCopy - end module ESMF_TimeMod + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimePrint - Print out a time instant's properties + + +! !INTERFACE: + subroutine ESMF_TimePrint(time, options, rc) + +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time + character (len=*), intent(in), optional :: options + integer, intent(out), optional :: rc + character (len=256) :: timestr + +! !DESCRIPTION: +! To support testing/debugging, print out a {\tt ESMF\_Time}'s +! properties. +! +! The arguments are: +! \begin{description} +! \item[time] +! {\tt ESMF\_Time} instant to print out +! \item[{[options]}] +! Print options +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + + ! Quick hack to mimic ESMF 2.0.1 + ! Really should check value of options... + IF ( PRESENT( options ) ) THEN + CALL ESMF_TimeGet( time, timeString=timestr, rc=rc ) + timestr(11:11) = 'T' ! ISO 8601 compatibility hack for debugging + print *,' Time -----------------------------------' + print *,' ',TRIM(timestr) + print *,' end Time -------------------------------' + print * + ELSE + call print_a_time (time) + ENDIF + + end subroutine ESMF_TimePrint + +!============================================================================== + +SUBROUTINE print_a_time( time ) + IMPLICIT NONE + type(ESMF_Time) time + character*128 :: s + integer rc + CALL ESMF_TimeGet( time, timeString=s, rc=rc ) + print *,'Print a time|',TRIM(s),'|' + write(0,*)'Print a time|',TRIM(s),'|' + return +END SUBROUTINE print_a_time + +!============================================================================== + +SUBROUTINE timecmp(time1, time2, retval ) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: retval +! +! !ARGUMENTS: + TYPE(ESMF_Time), INTENT(IN) :: time1 + TYPE(ESMF_Time), INTENT(IN) :: time2 + IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF + IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF + CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, & + time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, & + retval ) +END SUBROUTINE timecmp + +!============================================================================== + +SUBROUTINE normalize_time( time ) + ! A normalized time has time%basetime >= 0, time%basetime less than the current + ! year expressed as a timeInterval, and time%YR can take any value + IMPLICIT NONE + TYPE(ESMF_Time), INTENT(INOUT) :: time +! INTEGER(ESMF_KIND_I8) :: nsecondsinyear + ! locals + TYPE(ESMF_BaseTime) :: cmptime, zerotime + INTEGER :: rc + LOGICAL :: done + + ! first, normalize basetime + ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match + + CALL normalize_basetime( time%basetime ) + + ! next, underflow negative seconds into YEARS + ! time%basetime must end up non-negative + + zerotime%S = 0 + zerotime%Sn = 0 + zerotime%Sd = 0 + DO WHILE ( time%basetime < zerotime ) + time%YR = time%YR - 1 + cmptime%S = nsecondsinyear( time%YR, time%calendar%type ) + cmptime%Sn = 0 + cmptime%Sd = 0 + time%basetime = time%basetime + cmptime + ENDDO + + ! next, overflow seconds into YEARS + done = .FALSE. + DO WHILE ( .NOT. done ) + cmptime%S = nsecondsinyear( time%YR, time%calendar%type ) + cmptime%Sn = 0 + cmptime%Sd = 0 + IF ( time%basetime >= cmptime ) THEN + time%basetime = time%basetime - cmptime + time%YR = time%YR + 1 + ELSE + done = .TRUE. + ENDIF + ENDDO + +END SUBROUTINE normalize_time + +!============================================================================== + +SUBROUTINE timegetmonth( time, MM ) + IMPLICIT NONE + TYPE(ESMF_Time), INTENT(IN) :: time + INTEGER, INTENT(OUT) :: MM + ! locals + + mm = nmonthinyearsec(time%yr,time%basetime,time%calendar%type) + +END SUBROUTINE timegetmonth + +!============================================================================== +SUBROUTINE timegetdayofmonth( time, DD ) + IMPLICIT NONE + TYPE(ESMF_Time), INTENT(IN) :: time + INTEGER, INTENT(OUT) :: DD + ! locals + + dd = ndayinyearsec(time%yr, time%basetime, time%calendar%type) + +END SUBROUTINE timegetdayofmonth + +!============================================================================== + +! Increment Time by number of seconds between start of year and start +! of month MM. +! 1 <= MM <= 12 +! Time is NOT normalized. +SUBROUTINE timeaddmonths( time, MM, ierr ) + IMPLICIT NONE + TYPE(ESMF_Time), INTENT(INOUT) :: time + INTEGER, INTENT(IN) :: MM + INTEGER, INTENT(OUT) :: ierr + ! locals + INTEGER(ESMF_KIND_I8) :: isec + + ierr = ESMF_SUCCESS + IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN + CALL wrf_message( 'ERROR timeaddmonths(): MM out of range' ) + ierr = ESMF_FAILURE + return + ENDIF + + isec = nsecondsinyearmonth(time%yr,MM,time%calendar%type) + time%basetime%s = time%basetime%s + isec + +END SUBROUTINE timeaddmonths + +!============================================================================== + +! Increment Time by number of seconds between start of year and start +! of month MM. +! 1 <= MM <= 12 +! Time is NOT normalized. +SUBROUTINE ESMF_setYearWidth( yearWidthIn ) + + integer, intent(in) :: yearWidthIn + + yearWidth = yearWidthIn + +END SUBROUTINE ESMF_setYearWidth + +!============================================================================== +!============================================================================== +end module ESMF_TimeMod diff --git a/src/external/esmf_time_f90/Makefile b/src/external/esmf_time_f90/Makefile index 27380f1b08..192a52c2b6 100644 --- a/src/external/esmf_time_f90/Makefile +++ b/src/external/esmf_time_f90/Makefile @@ -1,108 +1,60 @@ -# To build this by itself, use the make target esmf_time_f90_only -# from the top-level WRF Makefile. -# > cd ../.. -# configure -# make esmf_time_f90_only - -.SUFFIXES: .F90 .o .f - -# get rid of single quotes after comments -# WARNING: This will break if a quoted string is followed by a comment that has -# a single quote. -SED_FTN = sed -e "/\!.*'/s/'//g" - -RM = /bin/rm -f -AR = ar -RANLIB = ranlib -FGREP = fgrep -iq - -OBJS = ESMF_Alarm.o ESMF_BaseTime.o ESMF_Clock.o ESMF_Time.o \ - Meat.o ESMF_Base.o ESMF_Calendar.o ESMF_Fraction.o \ - ESMF_TimeInterval.o ESMF_Stubs.o ESMF_Mod.o \ - module_symbols_util.o \ - module_utility.o ESMF_AlarmClock.o - -default: libesmf_time.a - -tests: Test1_ESMF.exe Test1_WRFU.exe - -libesmf_time.a : $(OBJS) - $(RM) libesmf_time.a - if [ "$(AR)" != "lib.exe" ] ; then \ - $(AR) ru libesmf_time.a $(OBJS) ; \ - else \ - $(AR) /out:libesmf_time.a $(OBJS) ; \ - fi - $(RANLIB) libesmf_time.a - -Test1_ESMF.f : Test1.F90 - $(RM) Test1_ESMF.b Test1_ESMF.f - cp Test1.F90 Test1_ESMF.b - $(CPP) -P -I. Test1_ESMF.b > Test1_ESMF.f - -Test1_ESMF.exe : libesmf_time.a Test1_ESMF.o - $(FC) -o Test1_ESMF.exe Test1_ESMF.o libesmf_time.a - -Test1_WRFU.f : Test1.F90 - $(RM) Test1_WRFU.b Test1_WRFU.f - sed -e "s/ESMF_Mod/module_utility/g" -e "s/ESMF_/WRFU_/g" Test1.F90 > Test1_WRFU.b - $(CPP) -P -I. Test1_WRFU.b > Test1_WRFU.f - -Test1_WRFU.exe : libesmf_time.a Test1_WRFU.o - $(FC) -o Test1_WRFU.exe Test1_WRFU.o libesmf_time.a - -.F90.o : - $(RM) $@ - $(SED_FTN) $*.F90 > $*.b -ifeq "$(GEN_F90)" "true" - $(CPP) -P -I. $*.b > $*.f - $(FC) -o $@ -c $*.f -else - $(FC) -o $@ -c $*.F90 -I. -endif - $(RM) $*.b - -.F90.f : - $(RM) $@ - $(SED_FTN) $*.F90 > $*.b - $(CPP) -P -I. $*.b > $*.f - $(RM) $*.b - -.f.o : - $(RM) $@ - $(RM) $*.b - $(FC) -c $*.f - -clean : testclean - -testclean: - $(RM) *.b *.f *.o *.obj *.i libesmf_time.a *.mod Test1*.exe - -superclean: testclean - $(RM) Test1*.out make_tests.out - -# DEPENDENCIES : only dependencies after this line - -#$$$ update dependencies! - -ESMF_Alarm.o : ESMF_BaseTime.o ESMF_Time.o ESMF_TimeInterval.o -ESMF_BaseTime.o : ESMF_Base.o -ESMF_Clock.o : ESMF_BaseTime.o ESMF_Time.o ESMF_TimeInterval.o -ESMF_AlarmClock.o : ESMF_Alarm.o ESMF_Clock.o -ESMF_Time.o : ESMF_BaseTime.o ESMF_TimeInterval.o ESMF_Calendar.o \ - ESMF_Stubs.o -ESMF_Base.o : -ESMF_Calendar.o : ESMF_BaseTime.o -ESMF_Fraction.o : ESMF_BaseTime.o -ESMF_TimeInterval.o : ESMF_BaseTime.o ESMF_Calendar.o ESMF_Fraction.o -ESMF_Mod.o : ESMF_Alarm.o ESMF_BaseTime.o ESMF_Clock.o ESMF_Time.o \ - ESMF_Base.o ESMF_Calendar.o ESMF_Fraction.o \ - ESMF_TimeInterval.o Meat.o ESMF_Stubs.o ESMF_AlarmClock.o -Meat.o : ESMF_Alarm.o ESMF_BaseTime.o ESMF_Clock.o ESMF_Time.o \ - ESMF_Base.o ESMF_Calendar.o ESMF_Fraction.o \ - ESMF_TimeInterval.o -ESMF_Stubs.o : ESMF_Base.o ESMF_Calendar.o -module_utility.o : ESMF_Mod.o module_symbols_util.o -module_symbols_util.o : ESMF_Mod.o -Test1.o : module_utility.o +.SUFFIXES: .F90 .o +OBJS = ESMF_AlarmClockMod.o \ + ESMF_AlarmMod.o \ + ESMF_BaseMod.o \ + ESMF_BaseTimeMod.o \ + ESMF_CalendarMod.o \ + ESMF_ClockMod.o \ + ESMF.o \ + ESMF_FractionMod.o \ + ESMF_ShrTimeMod.o \ + ESMF_Stubs.o \ + ESMF_TimeIntervalMod.o \ + ESMF_TimeMod.o \ + MeatMod.o \ + wrf_error_fatal.o \ + wrf_message.o + +all: $(OBJS) + ar -ru libesmf_time.a *.o + +ESMF_AlarmClockMod.o: ESMF_AlarmMod.o ESMF_ClockMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o + +ESMF_AlarmMod.o: ESMF_BaseMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o + +ESMF_BaseMod.o: + +ESMF_BaseTimeMod.o: ESMF_BaseMod.o + +ESMF_CalendarMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o + +ESMF_ClockMod.o: ESMF_BaseMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o ESMF_AlarmMod.o ESMF_TimeMod.o + +ESMF.o: ESMF_AlarmMod.o ESMF_BaseMod.o ESMF_BaseTimeMod.o \ + ESMF_CalendarMod.o ESMF_ClockMod.o ESMF_FractionMod.o \ + ESMF_TimeIntervalMod.o ESMF_TimeMod.o ESMF_ShrTimeMod.o \ + ESMF_AlarmClockMod.o ESMF_Stubs.o MeatMod.o + +ESMF_FractionMod.o: + +ESMF_ShrTimeMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_CalendarMod.o + +ESMF_Stubs.o: ESMF_BaseMod.o ESMF_CalendarMod.o + +ESMF_TimeIntervalMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_FractionMod.o ESMF_CalendarMod.o ESMF_ShrTimeMod.o + +ESMF_TimeMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_TimeIntervalMod.o ESMF_CalendarMod.o ESMF_ShrTimeMod.o ESMF_Stubs.o + +MeatMod.o: ESMF_BaseMod.o + +wrf_error_fatal.o: + +wrf_message.o: + +clean: + rm -rf *.o *.mod *.a + +.F90.o: + $(RM) $@ $*.mod + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I. diff --git a/src/external/esmf_time_f90/Meat.F90 b/src/external/esmf_time_f90/Meat.F90 deleted file mode 100644 index 9e5db27416..0000000000 --- a/src/external/esmf_time_f90/Meat.F90 +++ /dev/null @@ -1,928 +0,0 @@ -#include - -! Factor so abs(Sn) < Sd and ensure that signs of S and Sn match. -! Also, enforce consistency. -! YR and MM fields are ignored. - -SUBROUTINE normalize_basetime( basetime ) - USE esmf_basemod - USE esmf_basetimemod - IMPLICIT NONE - TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime -!PRINT *,'DEBUG: BEGIN normalize_basetime()' - ! Consistency check... - IF ( basetime%Sd < 0 ) THEN - CALL wrf_error_fatal( & - 'normalize_basetime: denominator of seconds cannot be negative' ) - ENDIF - IF ( ( basetime%Sd == 0 ) .AND. ( basetime%Sn .NE. 0 ) ) THEN - CALL wrf_error_fatal( & - 'normalize_basetime: denominator of seconds cannot be zero when numerator is non-zero' ) - ENDIF - ! factor so abs(Sn) < Sd - IF ( basetime%Sd > 0 ) THEN - IF ( ABS( basetime%Sn ) .GE. basetime%Sd ) THEN -!PRINT *,'DEBUG: normalize_basetime() A1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - basetime%S = basetime%S + ( basetime%Sn / basetime%Sd ) - basetime%Sn = mod( basetime%Sn, basetime%Sd ) -!PRINT *,'DEBUG: normalize_basetime() A2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - ENDIF - ! change sign of Sn if it does not match S - IF ( ( basetime%S > 0 ) .AND. ( basetime%Sn < 0 ) ) THEN -!PRINT *,'DEBUG: normalize_basetime() B1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - basetime%S = basetime%S - 1_ESMF_KIND_I8 - basetime%Sn = basetime%Sn + basetime%Sd -!PRINT *,'DEBUG: normalize_basetime() B2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - ENDIF - IF ( ( basetime%S < 0 ) .AND. ( basetime%Sn > 0 ) ) THEN -!PRINT *,'DEBUG: normalize_basetime() C1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - basetime%S = basetime%S + 1_ESMF_KIND_I8 - basetime%Sn = basetime%Sn - basetime%Sd -!PRINT *,'DEBUG: normalize_basetime() C2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd - ENDIF - ENDIF -!PRINT *,'DEBUG: END normalize_basetime()' -END SUBROUTINE normalize_basetime - - - -! A normalized time has time%basetime >= 0, time%basetime less than the current -! year expressed as a timeInterval, and time%YR can take any value -SUBROUTINE normalize_time( time ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timemod - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(INOUT) :: time - INTEGER(ESMF_KIND_I8) :: nsecondsinyear - ! locals - TYPE(ESMF_BaseTime) :: cmptime, zerotime - INTEGER :: rc - LOGICAL :: done - - ! first, normalize basetime - ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match - CALL normalize_basetime( time%basetime ) - -!$$$ add tests for these edge cases - - ! next, underflow negative seconds into YEARS - ! time%basetime must end up non-negative -!$$$ push this down into ESMF_BaseTime constructor - zerotime%S = 0 - zerotime%Sn = 0 - zerotime%Sd = 0 - DO WHILE ( time%basetime < zerotime ) - time%YR = time%YR - 1 -!$$$ push this down into ESMF_BaseTime constructor - cmptime%S = nsecondsinyear( time%YR ) - cmptime%Sn = 0 - cmptime%Sd = 0 - time%basetime = time%basetime + cmptime - ENDDO - - ! next, overflow seconds into YEARS - done = .FALSE. - DO WHILE ( .NOT. done ) -!$$$ push this down into ESMF_BaseTime constructor - cmptime%S = nsecondsinyear( time%YR ) - cmptime%Sn = 0 - cmptime%Sd = 0 - IF ( time%basetime >= cmptime ) THEN - time%basetime = time%basetime - cmptime - time%YR = time%YR + 1 - ELSE - done = .TRUE. - ENDIF - ENDDO -END SUBROUTINE normalize_time - - - -SUBROUTINE normalize_timeint( timeInt ) - USE esmf_basetimemod - USE esmf_timeintervalmod - IMPLICIT NONE - TYPE(ESMF_TimeInterval), INTENT(INOUT) :: timeInt - - ! normalize basetime - ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match - ! YR and MM are ignored - CALL normalize_basetime( timeInt%basetime ) -END SUBROUTINE normalize_timeint - - - - -FUNCTION signnormtimeint ( timeInt ) - ! Compute the sign of a time interval. - ! YR and MM fields are *IGNORED*. - ! returns 1, 0, or -1 or exits if timeInt fields have inconsistent signs. - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timeintervalmod - IMPLICIT NONE - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt - INTEGER :: signnormtimeint - LOGICAL :: positive, negative - - positive = .FALSE. - negative = .FALSE. - signnormtimeint = 0 - ! Note that Sd is required to be non-negative. This is enforced in - ! normalize_timeint(). - ! Note that Sn is required to be zero when Sd is zero. This is enforced - ! in normalize_timeint(). - IF ( ( timeInt%basetime%S > 0 ) .OR. & - ( timeInt%basetime%Sn > 0 ) ) THEN - positive = .TRUE. - ENDIF - IF ( ( timeInt%basetime%S < 0 ) .OR. & - ( timeInt%basetime%Sn < 0 ) ) THEN - negative = .TRUE. - ENDIF - IF ( positive .AND. negative ) THEN - CALL wrf_error_fatal( & - 'signnormtimeint: signs of fields cannot be mixed' ) - ELSE IF ( positive ) THEN - signnormtimeint = 1 - ELSE IF ( negative ) THEN - signnormtimeint = -1 - ENDIF -END FUNCTION signnormtimeint - - -! Exits with error message if timeInt is not normalized. -SUBROUTINE timeintchecknormalized( timeInt, msgstr ) - USE esmf_timeintervalmod - IMPLICIT NONE - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt - CHARACTER(LEN=*), INTENT(IN) :: msgstr - ! locals - CHARACTER(LEN=256) :: outstr - IF ( ( timeInt%YR /= 0 ) ) THEN - outstr = 'un-normalized TimeInterval not allowed: '//TRIM(msgstr) - CALL wrf_error_fatal( outstr ) - ENDIF -END SUBROUTINE timeintchecknormalized - - -! added from share/module_date_time in WRF. -FUNCTION nfeb ( year ) RESULT (num_days) - USE ESMF_CalendarMod - - ! Compute the number of days in February for the given year - IMPLICIT NONE - INTEGER :: year - INTEGER :: num_days - - type(ESMF_CalendarType) :: calendarType - - calendarType = ESMF_GetCalendarType() - - IF (calendarType % caltype == ESMF_CAL_NOLEAP % caltype) then - num_days = 28 - ELSE IF (calendarType % caltype == ESMF_CAL_360DAY % caltype) then - num_days = 30 - ELSE - num_days = 28 ! By default, February has 28 days ... - IF (MOD(year,4).eq.0) THEN - num_days = 29 ! But every four years, it has 29 days ... - IF (MOD(year,100).eq.0) THEN - num_days = 28 ! Except every 100 years, when it has 28 days ... - IF (MOD(year,400).eq.0) THEN - num_days = 29 ! Except every 400 years, when it has 29 days. - END IF - END IF - END IF - END IF - -END FUNCTION nfeb - - - -FUNCTION ndaysinyear ( year ) RESULT (num_diy) - ! Compute the number of days in the given year - IMPLICIT NONE - INTEGER, INTENT(IN) :: year - INTEGER :: num_diy - INTEGER :: nfeb -#if defined MARS - num_diy = 669 -#elif defined TITAN - num_diy = 686 -#else - IF ( nfeb( year ) .EQ. 29 ) THEN - num_diy = 366 - ELSE IF ( nfeb( year ) .EQ. 30 ) THEN - num_diy = 360 - ELSE - num_diy = 365 - ENDIF -#endif -END FUNCTION ndaysinyear - - - -FUNCTION nsecondsinyear ( year ) RESULT (numseconds) - ! Compute the number of seconds in the given year - USE esmf_basemod - IMPLICIT NONE - INTEGER, INTENT(IN) :: year - INTEGER(ESMF_KIND_I8) :: numseconds - INTEGER :: ndaysinyear - numseconds = SECONDS_PER_DAY * INT( ndaysinyear(year) , ESMF_KIND_I8 ) -END FUNCTION nsecondsinyear - - - -SUBROUTINE initdaym - USE esmf_basemod - USE esmf_basetimemod - USE ESMF_CalendarMod, only : months_per_year, mday, daym, mdaycum, monthbdys, & - mdayleap, mdayleapcum, monthbdysleap, daymleap - IMPLICIT NONE - INTEGER i,j,m - m = 1 - mdaycum(0) = 0 -!$$$ push this down into ESMF_BaseTime constructor - monthbdys(0)%S = 0 - monthbdys(0)%Sn = 0 - monthbdys(0)%Sd = 0 - DO i = 1,MONTHS_PER_YEAR - DO j = 1,mday(i) - daym(m) = i - m = m + 1 - ENDDO - mdaycum(i) = mdaycum(i-1) + mday(i) -!$$$ push this down into ESMF_BaseTime constructor - monthbdys(i)%S = SECONDS_PER_DAY * INT( mdaycum(i), ESMF_KIND_I8 ) - monthbdys(i)%Sn = 0 - monthbdys(i)%Sd = 0 - ENDDO - m = 1 - mdayleapcum(0) = 0 -!$$$ push this down into ESMF_BaseTime constructor - monthbdysleap(0)%S = 0 - monthbdysleap(0)%Sn = 0 - monthbdysleap(0)%Sd = 0 - DO i = 1,MONTHS_PER_YEAR - DO j = 1,mdayleap(i) - daymleap(m) = i - m = m + 1 - ENDDO - mdayleapcum(i) = mdayleapcum(i-1) + mdayleap(i) -!$$$ push this down into ESMF_BaseTime constructor - monthbdysleap(i)%S = SECONDS_PER_DAY * INT( mdayleapcum(i), ESMF_KIND_I8 ) - monthbdysleap(i)%Sn = 0 - monthbdysleap(i)%Sd = 0 - ENDDO -END SUBROUTINE initdaym - - -!$$$ useful, but not used at the moment... -SUBROUTINE compute_dayinyear(YR,MM,DD,dayinyear) - use ESMF_CalendarMod, only : mday -IMPLICIT NONE - INTEGER, INTENT(IN) :: YR,MM,DD ! DD is day of month - INTEGER, INTENT(OUT) :: dayinyear - INTEGER i - integer nfeb - -#ifdef PLANET - dayinyear = DD -#else - dayinyear = 0 - DO i = 1,MM-1 - if (i.eq.2) then - dayinyear = dayinyear + nfeb(YR) - else - dayinyear = dayinyear + mday(i) - endif - ENDDO - dayinyear = dayinyear + DD -#endif -END SUBROUTINE compute_dayinyear - - - -SUBROUTINE timegetmonth( time, MM ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timemod - USE ESMF_CalendarMod, only : MONTHS_PER_YEAR, monthbdys, monthbdysleap - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(IN) :: time - INTEGER, INTENT(OUT) :: MM - ! locals - INTEGER :: nfeb - INTEGER :: i -#if defined PLANET - MM = 0 -#else - MM = -1 - IF ( nfeb(time%YR) == 29 ) THEN - DO i = 1,MONTHS_PER_YEAR - IF ( ( time%basetime >= monthbdysleap(i-1) ) .AND. ( time%basetime < monthbdysleap(i) ) ) THEN - MM = i - EXIT - ENDIF - ENDDO - ELSE - DO i = 1,MONTHS_PER_YEAR - IF ( ( time%basetime >= monthbdys(i-1) ) .AND. ( time%basetime < monthbdys(i) ) ) THEN - MM = i - EXIT - ENDIF - ENDDO - ENDIF -#endif - IF ( MM == -1 ) THEN - CALL wrf_error_fatal( 'timegetmonth: could not extract month of year from time' ) - ENDIF -END SUBROUTINE timegetmonth - - -!$$$ may need to change dependencies in Makefile... - -SUBROUTINE timegetdayofmonth( time, DD ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timemod - USE esmf_calendarmod, only : monthbdys, monthbdysleap - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(IN) :: time - INTEGER, INTENT(OUT) :: DD - ! locals - INTEGER :: nfeb - INTEGER :: MM - TYPE(ESMF_BaseTime) :: tmpbasetime -#if defined PLANET - tmpbasetime = time%basetime -#else - CALL timegetmonth( time, MM ) - IF ( nfeb(time%YR) == 29 ) THEN - tmpbasetime = time%basetime - monthbdysleap(MM-1) - ELSE - tmpbasetime = time%basetime - monthbdys(MM-1) - ENDIF -#endif - DD = ( tmpbasetime%S / SECONDS_PER_DAY ) + 1 -END SUBROUTINE timegetdayofmonth - - -! Increment Time by number of seconds between start of year and start -! of month MM. -! 1 <= MM <= 12 -! Time is NOT normalized. -SUBROUTINE timeaddmonths( time, MM, ierr ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timemod - USE esmf_calendarmod, only : MONTHS_PER_YEAR, monthbdys, monthbdysleap - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(INOUT) :: time - INTEGER, INTENT(IN) :: MM - INTEGER, INTENT(OUT) :: ierr - ! locals - INTEGER :: nfeb - ierr = ESMF_SUCCESS -! PRINT *,'DEBUG: BEGIN timeaddmonths()' -#if defined PLANET -! time%basetime = time%basetime -#else - IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN - ierr = ESMF_FAILURE - ELSE - IF ( nfeb(time%YR) == 29 ) THEN - time%basetime = time%basetime + monthbdysleap(MM-1) - ELSE - time%basetime = time%basetime + monthbdys(MM-1) - ENDIF - ENDIF -#endif -END SUBROUTINE timeaddmonths - - -! Increment Time by number of seconds in the current month. -! Time is NOT normalized. -SUBROUTINE timeincmonth( time ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timemod - USE esmf_calendarmod, only : mday, mdayleap - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(INOUT) :: time - ! locals - INTEGER :: nfeb - INTEGER :: MM -#if defined PLANET -! time%basetime%S = time%basetime%S -#else - CALL timegetmonth( time, MM ) - IF ( nfeb(time%YR) == 29 ) THEN - time%basetime%S = time%basetime%S + & - ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY ) - ELSE - time%basetime%S = time%basetime%S + & - ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY ) - ENDIF -#endif -END SUBROUTINE timeincmonth - - - -! Decrement Time by number of seconds in the previous month. -! Time is NOT normalized. -SUBROUTINE timedecmonth( time ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timemod - USE esmf_calendarmod, only : mday, months_per_year, mdayleap - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(INOUT) :: time - ! locals - INTEGER :: nfeb - INTEGER :: MM -#if defined PLANET -! time%basetime%S = time%basetime%S -#else - CALL timegetmonth( time, MM ) ! current month, 1-12 - ! find previous month - MM = MM - 1 - IF ( MM == 0 ) THEN - ! wrap around Jan -> Dec - MM = MONTHS_PER_YEAR - ENDIF - IF ( nfeb(time%YR) == 29 ) THEN - time%basetime%S = time%basetime%S - & - ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY ) - ELSE - time%basetime%S = time%basetime%S - & - ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY ) - ENDIF -#endif -END SUBROUTINE timedecmonth - - - -! spaceship operator for Times -SUBROUTINE timecmp(time1, time2, retval ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timemod - IMPLICIT NONE - INTEGER, INTENT(OUT) :: retval -! -! !ARGUMENTS: - TYPE(ESMF_Time), INTENT(IN) :: time1 - TYPE(ESMF_Time), INTENT(IN) :: time2 - IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF - IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF - CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, & - time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, & - retval ) -END SUBROUTINE timecmp - - - -! spaceship operator for TimeIntervals -SUBROUTINE timeintcmp(timeint1, timeint2, retval ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timeintervalmod - IMPLICIT NONE - INTEGER, INTENT(OUT) :: retval -! -! !ARGUMENTS: - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2 - CALL timeintchecknormalized( timeint1, 'timeintcmp arg1' ) - CALL timeintchecknormalized( timeint2, 'timeintcmp arg2' ) - CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, & - timeint1%basetime%Sd, & - timeint2%basetime%S, timeint2%basetime%Sn, & - timeint2%basetime%Sd, retval ) -END SUBROUTINE timeintcmp - - - -! spaceship operator for seconds + Sn/Sd -SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval ) - USE esmf_basemod - IMPLICIT NONE - INTEGER, INTENT(OUT) :: retval -! -! !ARGUMENTS: - INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1 - INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2 -! local - INTEGER(ESMF_KIND_I8) :: lcd, n1, n2 - - n1 = Sn1 - n2 = Sn2 - if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then - CALL compute_lcd( Sd1, Sd2, lcd ) - if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 ) - if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 ) - endif - - if ( S1 .GT. S2 ) retval = 1 - if ( S1 .LT. S2 ) retval = -1 - IF ( S1 .EQ. S2 ) THEN - IF (n1 .GT. n2) retval = 1 - IF (n1 .LT. n2) retval = -1 - IF (n1 .EQ. n2) retval = 0 - ENDIF -END SUBROUTINE seccmp - - -SUBROUTINE c_esmc_basetimeeq (time1, time2, outflag) - USE esmf_alarmmod - USE esmf_basemod - USE esmf_basetimemod - USE esmf_calendarmod - USE esmf_clockmod - USE esmf_fractionmod - USE esmf_timeintervalmod - USE esmf_timemod -IMPLICIT NONE - logical, intent(OUT) :: outflag - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - integer res - CALL timecmp(time1,time2,res) - outflag = (res .EQ. 0) -END SUBROUTINE c_esmc_basetimeeq -SUBROUTINE c_esmc_basetimege(time1, time2, outflag) - USE esmf_alarmmod - USE esmf_basemod - USE esmf_basetimemod - USE esmf_calendarmod - USE esmf_clockmod - USE esmf_fractionmod - USE esmf_timeintervalmod - USE esmf_timemod - logical, intent(OUT) :: outflag - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - integer res - CALL timecmp(time1,time2,res) - outflag = (res .EQ. 1 .OR. res .EQ. 0) -END SUBROUTINE c_esmc_basetimege -SUBROUTINE c_esmc_basetimegt(time1, time2, outflag) - USE esmf_alarmmod - USE esmf_basemod - USE esmf_basetimemod - USE esmf_calendarmod - USE esmf_clockmod - USE esmf_fractionmod - USE esmf_timeintervalmod - USE esmf_timemod -IMPLICIT NONE - logical, intent(OUT) :: outflag - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - integer res - CALL timecmp(time1,time2,res) - outflag = (res .EQ. 1) -END SUBROUTINE c_esmc_basetimegt -SUBROUTINE c_esmc_basetimele(time1, time2, outflag) - USE esmf_alarmmod - USE esmf_basemod - USE esmf_basetimemod - USE esmf_calendarmod - USE esmf_clockmod - USE esmf_fractionmod - USE esmf_timeintervalmod - USE esmf_timemod -IMPLICIT NONE - logical, intent(OUT) :: outflag - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - integer res - CALL timecmp(time1,time2,res) - outflag = (res .EQ. -1 .OR. res .EQ. 0) -END SUBROUTINE c_esmc_basetimele -SUBROUTINE c_esmc_basetimelt(time1, time2, outflag) - USE esmf_alarmmod - USE esmf_basemod - USE esmf_basetimemod - USE esmf_calendarmod - USE esmf_clockmod - USE esmf_fractionmod - USE esmf_timeintervalmod - USE esmf_timemod -IMPLICIT NONE - logical, intent(OUT) :: outflag - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - integer res - CALL timecmp(time1,time2,res) - outflag = (res .EQ. -1) -END SUBROUTINE c_esmc_basetimelt -SUBROUTINE c_esmc_basetimene(time1, time2, outflag) - USE esmf_alarmmod - USE esmf_basemod - USE esmf_basetimemod - USE esmf_calendarmod - USE esmf_clockmod - USE esmf_fractionmod - USE esmf_timeintervalmod - USE esmf_timemod -IMPLICIT NONE - logical, intent(OUT) :: outflag - type(ESMF_Time), intent(in) :: time1 - type(ESMF_Time), intent(in) :: time2 - integer res - CALL timecmp(time1,time2,res) - outflag = (res .NE. 0) -END SUBROUTINE c_esmc_basetimene - -SUBROUTINE c_esmc_basetimeinteq(timeint1, timeint2, outflag) - USE esmf_timeintervalmod - IMPLICIT NONE - LOGICAL, INTENT(OUT) :: outflag - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2 - INTEGER :: res - CALL timeintcmp(timeint1,timeint2,res) - outflag = (res .EQ. 0) -END SUBROUTINE c_esmc_basetimeinteq -SUBROUTINE c_esmc_basetimeintne(timeint1, timeint2, outflag) - USE esmf_timeintervalmod - IMPLICIT NONE - LOGICAL, INTENT(OUT) :: outflag - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2 - INTEGER :: res - CALL timeintcmp(timeint1,timeint2,res) - outflag = (res .NE. 0) -END SUBROUTINE c_esmc_basetimeintne -SUBROUTINE c_esmc_basetimeintlt(timeint1, timeint2, outflag) - USE esmf_timeintervalmod - IMPLICIT NONE - LOGICAL, INTENT(OUT) :: outflag - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2 - INTEGER :: res - CALL timeintcmp(timeint1,timeint2,res) - outflag = (res .LT. 0) -END SUBROUTINE c_esmc_basetimeintlt -SUBROUTINE c_esmc_basetimeintgt(timeint1, timeint2, outflag) - USE esmf_timeintervalmod - IMPLICIT NONE - LOGICAL, INTENT(OUT) :: outflag - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2 - INTEGER :: res - CALL timeintcmp(timeint1,timeint2,res) - outflag = (res .GT. 0) -END SUBROUTINE c_esmc_basetimeintgt -SUBROUTINE c_esmc_basetimeintle(timeint1, timeint2, outflag) - USE esmf_timeintervalmod - IMPLICIT NONE - LOGICAL, INTENT(OUT) :: outflag - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2 - INTEGER :: res - CALL timeintcmp(timeint1,timeint2,res) - outflag = (res .LE. 0) -END SUBROUTINE c_esmc_basetimeintle -SUBROUTINE c_esmc_basetimeintge(timeint1, timeint2, outflag) - USE esmf_timeintervalmod - IMPLICIT NONE - LOGICAL, INTENT(OUT) :: outflag - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2 - INTEGER :: res - CALL timeintcmp(timeint1,timeint2,res) - outflag = (res .GE. 0) -END SUBROUTINE c_esmc_basetimeintge - -SUBROUTINE compute_lcd( e1, e2, lcd ) - USE esmf_basemod - IMPLICIT NONE - INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2 - INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd - INTEGER, PARAMETER :: nprimes = 9 - INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) - INTEGER i - INTEGER(ESMF_KIND_I8) d1, d2, p - - d1 = e1 ; d2 = e2 - IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF - IF ( d1 .EQ. 0 ) d1 = d2 - IF ( d2 .EQ. 0 ) d2 = d1 - IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF - lcd = d1 * d2 - DO i = 1, nprimes - p = primes(i) - DO WHILE (lcd/p .NE. 0 .AND. & - mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0) - lcd = lcd / p - END DO - ENDDO -END SUBROUTINE compute_lcd - -SUBROUTINE simplify( ni, di, no, do ) - USE esmf_basemod - IMPLICIT NONE - INTEGER(ESMF_KIND_I8), INTENT(IN) :: ni, di - INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do - INTEGER, PARAMETER :: nprimes = 9 - INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) - INTEGER(ESMF_KIND_I8) :: pr, d, n - INTEGER :: np - LOGICAL keepgoing - IF ( ni .EQ. 0 ) THEN - do = 1 - no = 0 - RETURN - ENDIF - IF ( mod( di , ni ) .EQ. 0 ) THEN - do = di / ni - no = 1 - RETURN - ENDIF - d = di - n = ni - DO np = 1, nprimes - pr = primes(np) - keepgoing = .TRUE. - DO WHILE ( keepgoing ) - keepgoing = .FALSE. - IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN - d = d / pr - n = n / pr - keepgoing = .TRUE. - ENDIF - ENDDO - ENDDO - do = d - no = n - RETURN -END SUBROUTINE simplify - - -!$$$ this should be named "c_esmc_timesum" or something less misleading -SUBROUTINE c_esmc_basetimesum( time1, timeinterval, timeOut ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timeintervalmod - USE esmf_timemod - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(IN) :: time1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval - TYPE(ESMF_Time), INTENT(INOUT) :: timeOut - ! locals - INTEGER :: m - timeOut = time1 - timeOut%basetime = timeOut%basetime + timeinterval%basetime -#if 0 -!jm Month has no meaning for a timeinterval; removed 20100319 -#if defined PLANET - ! Do nothing... -#else - DO m = 1, abs(timeinterval%MM) - IF ( timeinterval%MM > 0 ) THEN - CALL timeincmonth( timeOut ) - ELSE - CALL timedecmonth( timeOut ) - ENDIF - ENDDO -#endif -#endif - timeOut%YR = timeOut%YR + timeinterval%YR - CALL normalize_time( timeOut ) -END SUBROUTINE c_esmc_basetimesum - - -!$$$ this should be named "c_esmc_timedec" or something less misleading -SUBROUTINE c_esmc_basetimedec( time1, timeinterval, timeOut ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timeintervalmod - USE esmf_timemod - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(IN) :: time1 - TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval - TYPE(ESMF_Time), INTENT(OUT) :: timeOut - ! locals - TYPE (ESMF_TimeInterval) :: neginterval - neginterval = timeinterval -!$$$push this down into a unary negation operator on TimeInterval - neginterval%basetime%S = -neginterval%basetime%S - neginterval%basetime%Sn = -neginterval%basetime%Sn - neginterval%YR = -neginterval%YR -#if 0 -!jm month has no meaning for an interval; removed 20100319 -#ifndef PLANET - neginterval%MM = -neginterval%MM -#endif -#endif - timeOut = time1 + neginterval -END SUBROUTINE c_esmc_basetimedec - - -!$$$ this should be named "c_esmc_timediff" or something less misleading -SUBROUTINE c_esmc_basetimediff( time1, time2, timeIntOut ) - USE esmf_basemod - USE esmf_basetimemod - USE esmf_timeintervalmod - USE esmf_timemod - IMPLICIT NONE - TYPE(ESMF_Time), INTENT(IN) :: time1 - TYPE(ESMF_Time), INTENT(IN) :: time2 - TYPE(ESMF_TimeInterval), INTENT(OUT) :: timeIntOut - ! locals - INTEGER(ESMF_KIND_I8) :: nsecondsinyear - INTEGER :: yr - CALL ESMF_TimeIntervalSet( timeIntOut ) - timeIntOut%basetime = time1%basetime - time2%basetime - ! convert difference in years to basetime... - IF ( time1%YR > time2%YR ) THEN - DO yr = time2%YR, ( time1%YR - 1 ) - timeIntOut%basetime%S = timeIntOut%basetime%S + nsecondsinyear( yr ) - ENDDO - ELSE IF ( time2%YR > time1%YR ) THEN - DO yr = time1%YR, ( time2%YR - 1 ) - timeIntOut%basetime%S = timeIntOut%basetime%S - nsecondsinyear( yr ) - ENDDO - ENDIF -!$$$ add tests for multi-year differences - CALL normalize_timeint( timeIntOut ) -END SUBROUTINE c_esmc_basetimediff - - -! some extra wrf stuff - - -! Convert fraction to string with leading sign. -! If fraction simplifies to a whole number or if -! denominator is zero, return empty string. -! INTEGER*8 interface. -SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str ) - USE ESMF_basemod - IMPLICIT NONE - INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator - INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator - CHARACTER (LEN=*), INTENT(OUT) :: frac_str - IF ( denominator > 0 ) THEN - IF ( mod( numerator, denominator ) /= 0 ) THEN - IF ( numerator > 0 ) THEN - WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator - ELSE ! numerator < 0 - WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator - ENDIF - ELSE ! includes numerator == 0 case - frac_str = '' - ENDIF - ELSE ! no-fraction case - frac_str = '' - ENDIF -END SUBROUTINE fraction_to_stringi8 - - -! Convert fraction to string with leading sign. -! If fraction simplifies to a whole number or if -! denominator is zero, return empty string. -! INTEGER interface. -SUBROUTINE fraction_to_string( numerator, denominator, frac_str ) - USE ESMF_basemod - IMPLICIT NONE - INTEGER, INTENT(IN) :: numerator - INTEGER, INTENT(IN) :: denominator - CHARACTER (LEN=*), INTENT(OUT) :: frac_str - ! locals - INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8 - numerator_i8 = INT( numerator, ESMF_KIND_I8 ) - denominator_i8 = INT( denominator, ESMF_KIND_I8 ) - CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str ) -END SUBROUTINE fraction_to_string - - -SUBROUTINE print_a_time( time ) - use ESMF_basemod - use ESMF_Timemod - IMPLICIT NONE - type(ESMF_Time) time - character*128 :: s - integer rc - CALL ESMF_TimeGet( time, timeString=s, rc=rc ) - print *,'Print a time|',TRIM(s),'|' - return -END SUBROUTINE print_a_time - -SUBROUTINE print_a_timeinterval( time ) - use ESMF_basemod - use ESMF_TimeIntervalmod - IMPLICIT NONE - type(ESMF_TimeInterval) time - character*128 :: s - integer rc - CALL ESMFold_TimeIntervalGetString( time, s, rc ) - print *,'Print a time interval|',TRIM(s),'|' - return -END SUBROUTINE print_a_timeinterval - diff --git a/src/external/esmf_time_f90/MeatMod.F90 b/src/external/esmf_time_f90/MeatMod.F90 new file mode 100644 index 0000000000..c9ab2ec145 --- /dev/null +++ b/src/external/esmf_time_f90/MeatMod.F90 @@ -0,0 +1,66 @@ + +module MeatMod + +#include + + use ESMF_BaseMod + + implicit none + + private + + public fraction_to_stringi8 + public fraction_to_string + +!============================================================================== +contains +!============================================================================== + +!============================================================================== + +!============================================================================== +! Convert fraction to string with leading sign. +! If fraction simplifies to a whole number or if +! denominator is zero, return empty string. +! INTEGER*8 interface. +SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str ) + IMPLICIT NONE + INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator + INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator + CHARACTER (LEN=*), INTENT(OUT) :: frac_str + IF ( denominator > 0 ) THEN + IF ( mod( numerator, denominator ) /= 0 ) THEN + IF ( numerator > 0 ) THEN + WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator + ELSE ! numerator < 0 + WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator + ENDIF + ELSE ! includes numerator == 0 case + frac_str = '' + ENDIF + ELSE ! no-fraction case + frac_str = '' + ENDIF +END SUBROUTINE fraction_to_stringi8 + +!============================================================================== + +! Convert fraction to string with leading sign. +! If fraction simplifies to a whole number or if +! denominator is zero, return empty string. +! INTEGER interface. +SUBROUTINE fraction_to_string( numerator, denominator, frac_str ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: numerator + INTEGER, INTENT(IN) :: denominator + CHARACTER (LEN=*), INTENT(OUT) :: frac_str + ! locals + INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8 + numerator_i8 = INT( numerator, ESMF_KIND_I8 ) + denominator_i8 = INT( denominator, ESMF_KIND_I8 ) + CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str ) +END SUBROUTINE fraction_to_string + +!============================================================================== + +end module MeatMod diff --git a/src/external/esmf_time_f90/README b/src/external/esmf_time_f90/README new file mode 100644 index 0000000000..e8c73ef5fe --- /dev/null +++ b/src/external/esmf_time_f90/README @@ -0,0 +1,19 @@ + +Quick README +Tony Craig, Feb, 2012 + +This is a partial substitute for the ESMF Time Manager. As of Feb, 2012, +what exists is consist (in interfaces and datatypes) with ESMF 5.2.0rp1. +The datatypes in this version are not interchangable with ESMF nor will the +answers be exactly identical. + +This version supports the NOLEAP and GREGORIAN calendar. It also supports +use of the D and Dl interfaces in ESMF_TimeSet and ESMF_TimeGet. The julian +day reference is that day 1 is year 0, month 1, day 1 (0000-01-01 or Jan 1, 0000). +It also supports positive or negative years. + +Several aspects of the ESMF interfaces are not supported. + +There is a unit tester that tests ESMF_Time and ESMF_TimeInterval actions +for both gregorian and noleap calendar. + diff --git a/src/external/esmf_time_f90/Test1.F90 b/src/external/esmf_time_f90/Test1.F90 deleted file mode 100644 index ae7d29fc99..0000000000 --- a/src/external/esmf_time_f90/Test1.F90 +++ /dev/null @@ -1,1718 +0,0 @@ -! -! Sub-system tests for esmf_time_f90 -! -! Someday, switch over to funit! -! - -MODULE my_tests - USE ESMF_Mod - IMPLICIT NONE - - ! Set this to .TRUE. to make wrf_error_fatal3() print a message on failure - ! instead of stopping the program. Use for testing only (since we cannot - ! catch exceptions in Fortran90!!) - LOGICAL :: WRF_ERROR_FATAL_PRINT = .FALSE. - -CONTAINS - - ! Test printing of an ESMF_Time or ESMF_TimeInterval object. - ! - ! Correct results are also passed in through this interface and compared - ! with computed results. PASS/FAIL messages are printed. - ! - SUBROUTINE test_print( t_yy, t_mm, t_dd, t_h, t_m, t_s, t_sn, t_sd, & - ti_yy, ti_mm, ti_dd, ti_h, ti_m, ti_s, ti_sn, ti_sd, & - res_str, testname, expect_error ) - INTEGER, INTENT(IN), OPTIONAL :: t_YY - INTEGER, INTENT(IN), OPTIONAL :: t_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: t_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: t_H - INTEGER, INTENT(IN), OPTIONAL :: t_M - INTEGER, INTENT(IN), OPTIONAL :: t_S - INTEGER, INTENT(IN), OPTIONAL :: t_Sn - INTEGER, INTENT(IN), OPTIONAL :: t_Sd - INTEGER, INTENT(IN), OPTIONAL :: ti_YY - INTEGER, INTENT(IN), OPTIONAL :: ti_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: ti_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: ti_H - INTEGER, INTENT(IN), OPTIONAL :: ti_M - INTEGER, INTENT(IN), OPTIONAL :: ti_S - INTEGER, INTENT(IN), OPTIONAL :: ti_Sn - INTEGER, INTENT(IN), OPTIONAL :: ti_Sd - CHARACTER (LEN=*), INTENT(IN) :: res_str - CHARACTER (LEN=*), INTENT(IN), OPTIONAL :: testname - LOGICAL, OPTIONAL, INTENT(IN) :: expect_error - ! locals - INTEGER :: it_YY - INTEGER :: it_MM ! month - INTEGER :: it_DD ! day of month - INTEGER :: it_H - INTEGER :: it_M - INTEGER :: it_S - INTEGER :: it_Sn - INTEGER :: it_Sd - INTEGER :: iti_YY - INTEGER :: iti_MM ! month - INTEGER :: iti_DD ! day of month - INTEGER :: iti_H - INTEGER :: iti_M - INTEGER :: iti_S - INTEGER :: iti_Sn - INTEGER :: iti_Sd - LOGICAL :: is_t - LOGICAL :: is_ti - CHARACTER (LEN=512) :: itestname - LOGICAL :: iexpect_error - INTEGER rc - TYPE(ESMF_Time) :: t - TYPE(ESMF_TimeInterval) :: ti - CHARACTER(LEN=ESMF_MAXSTR) :: str, computed_str, frac_str - CHARACTER(LEN=17) :: type_str - INTEGER :: res_len, computed_len, Sn, Sd - LOGICAL :: test_passed - -! PRINT *,'DEBUG: BEGIN test_print()' - it_YY = 0 - it_MM = 1 - it_DD = 1 - it_H = 0 - it_M = 0 - it_S = 0 - it_Sn = 0 - it_Sd = 0 - iti_YY = 0 - iti_MM = 0 - iti_DD = 0 - iti_H = 0 - iti_M = 0 - iti_S = 0 - iti_Sn = 0 - iti_Sd = 0 - itestname = '' - iexpect_error = .FALSE. - - IF ( PRESENT( t_YY ) ) it_YY = t_YY - IF ( PRESENT( t_MM ) ) it_MM = t_MM - IF ( PRESENT( t_DD ) ) it_DD = t_DD - IF ( PRESENT( t_H ) ) it_H = t_H - IF ( PRESENT( t_M ) ) it_M = t_M - IF ( PRESENT( t_S ) ) it_S = t_S - IF ( PRESENT( t_Sn ) ) it_Sn = t_Sn - IF ( PRESENT( t_Sd ) ) it_Sd = t_Sd - IF ( PRESENT( ti_YY ) ) iti_YY = ti_YY - IF ( PRESENT( ti_MM ) ) iti_MM = ti_MM - IF ( PRESENT( ti_DD ) ) iti_DD = ti_DD - IF ( PRESENT( ti_H ) ) iti_H = ti_H - IF ( PRESENT( ti_M ) ) iti_M = ti_M - IF ( PRESENT( ti_S ) ) iti_S = ti_S - IF ( PRESENT( ti_Sn ) ) iti_Sn = ti_Sn - IF ( PRESENT( ti_Sd ) ) iti_Sd = ti_Sd - IF ( PRESENT( testname ) ) itestname = TRIM(testname) - IF ( PRESENT( expect_error ) ) iexpect_error = expect_error - - ! Ensure that optional arguments are consistent... - is_t = ( PRESENT( t_YY ) .OR. PRESENT( t_MM ) .OR. & - PRESENT( t_DD ) .OR. PRESENT( t_H ) .OR. & - PRESENT( t_M ) .OR. PRESENT( t_S ) .OR. & - PRESENT( t_Sn ) .OR. PRESENT( t_Sd ) ) - is_ti = ( PRESENT( ti_YY ) .OR. PRESENT( ti_MM ) .OR. & - PRESENT( ti_DD ) .OR. PRESENT( ti_H ) .OR. & - PRESENT( ti_M ) .OR. PRESENT( ti_S ) .OR. & - PRESENT( ti_Sn ) .OR. PRESENT( ti_Sd ) ) - IF ( is_t .EQV. is_ti ) THEN - CALL wrf_error_fatal3( __FILE__ , __LINE__ , & - 'ERROR test_print: inconsistent args' ) - ENDIF - -!PRINT *,'DEBUG: test_print(): init objects' - ! Initialize object to be tested - ! modify behavior of wrf_error_fatal3 for tests expected to fail - IF ( iexpect_error ) WRF_ERROR_FATAL_PRINT = .TRUE. - Sn = 0 - Sd = 0 - IF ( is_t ) THEN - type_str = 'ESMF_Time' -!PRINT *,'DEBUG: test_print(): calling ESMF_TimeSet()' -!PRINT *,'DEBUG: test_print(): YY,MM,DD,H,M,S,Sn,Sd = ', it_YY,it_MM,it_DD,it_H,it_M,it_S,it_Sn,it_Sd - CALL ESMF_TimeSet( t, YY=it_YY, MM=it_MM, DD=it_DD , & - H=it_H, M=it_M, S=it_S, Sn=it_Sn, Sd=it_Sd, rc=rc ) -!PRINT *,'DEBUG: test_print(): back from ESMF_TimeSet()' - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeSet() ', & - __FILE__ , & - __LINE__ ) -!PRINT *,'DEBUG: test_print(): calling ESMF_TimeGet()' - CALL ESMF_TimeGet( t, timeString=computed_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) -!PRINT *,'DEBUG: test_print(): back from ESMF_TimeGet(), computed_str = ',TRIM(computed_str) - ELSE - type_str = 'ESMF_TimeInterval' -!PRINT *,'DEBUG: test_print(): calling ESMF_TimeIntervalSet()' - CALL ESMF_TimeIntervalSet( ti, YY=iti_YY, MM=iti_MM, & - D=iti_DD , & - H=iti_H, M=iti_M, & - S=iti_S, Sn=iti_Sn, Sd=iti_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeIntervalSet() ', & - __FILE__ , & - __LINE__ ) -!PRINT *,'DEBUG: test_print(): calling ESMF_TimeIntervalGet()' - CALL ESMF_TimeIntervalGet( ti, timeString=computed_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ENDIF - ! handle fractions - IF ( Sd > 0 ) THEN - IF ( Sn > 0 ) THEN - WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(Sn), Sd - ELSE IF ( Sn < 0 ) THEN - WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(Sn), Sd - ELSE - frac_str = '' - ENDIF - computed_str = TRIM(computed_str)//TRIM(frac_str) - ENDIF - ! restore default behavior of wrf_error_fatal3 - IF ( iexpect_error ) WRF_ERROR_FATAL_PRINT = .FALSE. -!PRINT *,'DEBUG: test_print(): done init objects' - -!PRINT *,'DEBUG: test_print(): check result' - ! check result - test_passed = .FALSE. - res_len = LEN_TRIM(res_str) - computed_len = LEN_TRIM(computed_str) - IF ( res_len == computed_len ) THEN - IF ( computed_str(1:computed_len) == res_str(1:res_len) ) THEN - test_passed = .TRUE. - ENDIF - ENDIF - IF ( test_passed ) THEN - WRITE(*,FMT='(A)') 'PASS: '//TRIM(itestname) - ELSE - WRITE(*,'(9A)') 'FAIL: ',TRIM(itestname),': printing ',TRIM(type_str), & - ' expected <', TRIM(res_str),'> but computed <',TRIM(computed_str),'>' - ENDIF -!PRINT *,'DEBUG: END test_print()' - - END SUBROUTINE test_print - - - - ! Test the following arithmetic operations on ESMF_Time and - ! ESMF_TimeInterval objects: - ! ESMF_Time = ESMF_Time + ESMF_TimeInterval - ! ESMF_Time = ESMF_TimeInterval + ESMF_Time - ! ESMF_Time = ESMF_Time - ESMF_TimeInterval - ! ESMF_TimeInterval = ESMF_Time - ESMF_Time - ! ESMF_TimeInterval = ESMF_TimeInterval + ESMF_TimeInterval - ! ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval - ! ESMF_TimeInterval = ESMF_TimeInterval * INTEGER - ! ESMF_TimeInterval = ESMF_TimeInterval / INTEGER - ! - ! Correct results are also passed in through this interface and compared - ! with computed results. PASS/FAIL messages are printed. - ! - ! Operations are expressed as res = op1 +|- op2 - ! - SUBROUTINE test_arithmetic( add_op, multiply_op, & - op1_t_yy, op1_t_mm, op1_t_dd, op1_t_h, op1_t_m, op1_t_s, op1_t_sn, op1_t_sd, & - op1_ti_yy, op1_ti_mm, op1_ti_dd, op1_ti_h, op1_ti_m, op1_ti_s, op1_ti_sn, op1_ti_sd, & - op2_t_yy, op2_t_mm, op2_t_dd, op2_t_h, op2_t_m, op2_t_s, op2_t_sn, op2_t_sd, & - op2_ti_yy, op2_ti_mm, op2_ti_dd, op2_ti_h, op2_ti_m, op2_ti_s, op2_ti_sn, op2_ti_sd, & - op2_int, & - res_t_yy, res_t_mm, res_t_dd, res_t_h, res_t_m, res_t_s, res_t_sn, res_t_sd, & - res_ti_yy, res_ti_mm, res_ti_dd, res_ti_h, res_ti_m, res_ti_s, res_ti_sn, res_ti_sd, & - res_int, testname, expect_error ) - LOGICAL, INTENT(IN), OPTIONAL :: add_op ! .TRUE.=add, .FALSE.=subtract - LOGICAL, INTENT(IN), OPTIONAL :: multiply_op ! .TRUE.=multiply, .FALSE.=divide - INTEGER, INTENT(IN), OPTIONAL :: op1_t_YY - INTEGER, INTENT(IN), OPTIONAL :: op1_t_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: op1_t_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: op1_t_H - INTEGER, INTENT(IN), OPTIONAL :: op1_t_M - INTEGER, INTENT(IN), OPTIONAL :: op1_t_S - INTEGER, INTENT(IN), OPTIONAL :: op1_t_Sn - INTEGER, INTENT(IN), OPTIONAL :: op1_t_Sd - INTEGER, INTENT(IN), OPTIONAL :: op1_ti_YY - INTEGER, INTENT(IN), OPTIONAL :: op1_ti_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: op1_ti_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: op1_ti_H - INTEGER, INTENT(IN), OPTIONAL :: op1_ti_M - INTEGER, INTENT(IN), OPTIONAL :: op1_ti_S - INTEGER, INTENT(IN), OPTIONAL :: op1_ti_Sn - INTEGER, INTENT(IN), OPTIONAL :: op1_ti_Sd - INTEGER, INTENT(IN), OPTIONAL :: op2_t_YY - INTEGER, INTENT(IN), OPTIONAL :: op2_t_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: op2_t_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: op2_t_H - INTEGER, INTENT(IN), OPTIONAL :: op2_t_M - INTEGER, INTENT(IN), OPTIONAL :: op2_t_S - INTEGER, INTENT(IN), OPTIONAL :: op2_t_Sn - INTEGER, INTENT(IN), OPTIONAL :: op2_t_Sd - INTEGER, INTENT(IN), OPTIONAL :: op2_ti_YY - INTEGER, INTENT(IN), OPTIONAL :: op2_ti_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: op2_ti_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: op2_ti_H - INTEGER, INTENT(IN), OPTIONAL :: op2_ti_M - INTEGER, INTENT(IN), OPTIONAL :: op2_ti_S - INTEGER, INTENT(IN), OPTIONAL :: op2_ti_Sn - INTEGER, INTENT(IN), OPTIONAL :: op2_ti_Sd - INTEGER, INTENT(IN), OPTIONAL :: op2_int - INTEGER, INTENT(IN), OPTIONAL :: res_t_YY - INTEGER, INTENT(IN), OPTIONAL :: res_t_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: res_t_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: res_t_H - INTEGER, INTENT(IN), OPTIONAL :: res_t_M - INTEGER, INTENT(IN), OPTIONAL :: res_t_S - INTEGER, INTENT(IN), OPTIONAL :: res_t_Sn - INTEGER, INTENT(IN), OPTIONAL :: res_t_Sd - INTEGER, INTENT(IN), OPTIONAL :: res_ti_YY - INTEGER, INTENT(IN), OPTIONAL :: res_ti_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: res_ti_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: res_ti_H - INTEGER, INTENT(IN), OPTIONAL :: res_ti_M - INTEGER, INTENT(IN), OPTIONAL :: res_ti_S - INTEGER, INTENT(IN), OPTIONAL :: res_ti_Sn - INTEGER, INTENT(IN), OPTIONAL :: res_ti_Sd - INTEGER, INTENT(IN), OPTIONAL :: res_int - CHARACTER (LEN=*), OPTIONAL, INTENT(IN) :: testname - LOGICAL, OPTIONAL, INTENT(IN) :: expect_error - ! locals - LOGICAL :: iadd_op - LOGICAL :: isubtract_op - LOGICAL :: imultiply_op - LOGICAL :: idivide_op - INTEGER :: iop1_t_YY - INTEGER :: iop1_t_MM ! month - INTEGER :: iop1_t_DD ! day of month - INTEGER :: iop1_t_H - INTEGER :: iop1_t_M - INTEGER :: iop1_t_S - INTEGER :: iop1_t_Sn - INTEGER :: iop1_t_Sd - INTEGER :: iop1_ti_YY - INTEGER :: iop1_ti_MM ! month - INTEGER :: iop1_ti_DD ! day of month - INTEGER :: iop1_ti_H - INTEGER :: iop1_ti_M - INTEGER :: iop1_ti_S - INTEGER :: iop1_ti_Sn - INTEGER :: iop1_ti_Sd - INTEGER :: iop2_t_YY - INTEGER :: iop2_t_MM ! month - INTEGER :: iop2_t_DD ! day of month - INTEGER :: iop2_t_H - INTEGER :: iop2_t_M - INTEGER :: iop2_t_S - INTEGER :: iop2_t_Sn - INTEGER :: iop2_t_Sd - INTEGER :: iop2_ti_YY - INTEGER :: iop2_ti_MM ! month - INTEGER :: iop2_ti_DD ! day of month - INTEGER :: iop2_ti_H - INTEGER :: iop2_ti_M - INTEGER :: iop2_ti_S - INTEGER :: iop2_ti_Sn - INTEGER :: iop2_ti_Sd - INTEGER :: ires_t_YY - INTEGER :: ires_t_MM ! month - INTEGER :: ires_t_DD ! day of month - INTEGER :: ires_t_H - INTEGER :: ires_t_M - INTEGER :: ires_t_S - INTEGER :: ires_t_Sn - INTEGER :: ires_t_Sd - INTEGER :: ires_ti_YY - INTEGER :: ires_ti_MM ! month - INTEGER :: ires_ti_DD ! day of month - INTEGER :: ires_ti_H - INTEGER :: ires_ti_M - INTEGER :: ires_ti_S - INTEGER :: ires_ti_Sn - INTEGER :: ires_ti_Sd - LOGICAL :: op1_is_t , op2_is_t , res_is_t - LOGICAL :: op1_is_ti, op2_is_ti, res_is_ti, op2_is_int - LOGICAL :: res_is_int - INTEGER :: num_ops, num_op1, num_op2, num_res - LOGICAL :: unsupported_op, test_passed - CHARACTER (LEN=512) :: itestname - LOGICAL :: iexpect_error - INTEGER :: rc - INTEGER :: computed_int, Sn, Sd - TYPE(ESMF_Time) :: op1_t , op2_t , res_t, computed_t - TYPE(ESMF_TimeInterval) :: op1_ti, op2_ti, res_ti, computed_ti - CHARACTER(LEN=ESMF_MAXSTR) :: str, op1_str, op2_str, res_str, computed_str, frac_str - CHARACTER(LEN=1) :: op_str - CHARACTER(LEN=17) :: op1_type_str, op2_type_str, res_type_str - - iadd_op = .FALSE. - isubtract_op = .FALSE. - imultiply_op = .FALSE. - idivide_op = .FALSE. - iop1_t_YY = 0 - iop1_t_MM = 1 - iop1_t_DD = 1 - iop1_t_H = 0 - iop1_t_M = 0 - iop1_t_S = 0 - iop1_t_Sn = 0 - iop1_t_Sd = 0 - iop1_ti_YY = 0 - iop1_ti_MM = 0 - iop1_ti_DD = 0 - iop1_ti_H = 0 - iop1_ti_M = 0 - iop1_ti_S = 0 - iop1_ti_Sn = 0 - iop1_ti_Sd = 0 - iop2_t_YY = 0 - iop2_t_MM = 1 - iop2_t_DD = 1 - iop2_t_H = 0 - iop2_t_M = 0 - iop2_t_S = 0 - iop2_t_Sn = 0 - iop2_t_Sd = 0 - iop2_ti_YY = 0 - iop2_ti_MM = 0 - iop2_ti_DD = 0 - iop2_ti_H = 0 - iop2_ti_M = 0 - iop2_ti_S = 0 - iop2_ti_Sn = 0 - iop2_ti_Sd = 0 - ires_t_YY = 0 - ires_t_MM = 1 - ires_t_DD = 1 - ires_t_H = 0 - ires_t_M = 0 - ires_t_S = 0 - ires_t_Sn = 0 - ires_t_Sd = 0 - ires_ti_YY = 0 - ires_ti_MM = 0 - ires_ti_DD = 0 - ires_ti_H = 0 - ires_ti_M = 0 - ires_ti_S = 0 - ires_ti_Sn = 0 - ires_ti_Sd = 0 - itestname = '' - iexpect_error = .FALSE. - - IF ( PRESENT( add_op ) ) THEN - iadd_op = add_op - isubtract_op = ( .NOT. add_op ) - ENDIF - IF ( PRESENT( multiply_op ) ) THEN - imultiply_op = multiply_op - idivide_op = ( .NOT. multiply_op ) - ENDIF - num_ops = 0 - IF ( iadd_op ) num_ops = num_ops + 1 - IF ( isubtract_op ) num_ops = num_ops + 1 - IF ( imultiply_op ) num_ops = num_ops + 1 - IF ( idivide_op ) num_ops = num_ops + 1 - IF ( num_ops /= 1 ) THEN - CALL wrf_error_fatal3( __FILE__ , __LINE__ , & - 'ERROR test_arithmetic: inconsistent operation' ) - ENDIF - IF ( PRESENT( op1_t_YY ) ) iop1_t_YY = op1_t_YY - IF ( PRESENT( op1_t_MM ) ) iop1_t_MM = op1_t_MM - IF ( PRESENT( op1_t_DD ) ) iop1_t_DD = op1_t_DD - IF ( PRESENT( op1_t_H ) ) iop1_t_H = op1_t_H - IF ( PRESENT( op1_t_M ) ) iop1_t_M = op1_t_M - IF ( PRESENT( op1_t_S ) ) iop1_t_S = op1_t_S - IF ( PRESENT( op1_t_Sn ) ) iop1_t_Sn = op1_t_Sn - IF ( PRESENT( op1_t_Sd ) ) iop1_t_Sd = op1_t_Sd - IF ( PRESENT( op1_ti_YY ) ) iop1_ti_YY = op1_ti_YY - IF ( PRESENT( op1_ti_MM ) ) iop1_ti_MM = op1_ti_MM - IF ( PRESENT( op1_ti_DD ) ) iop1_ti_DD = op1_ti_DD - IF ( PRESENT( op1_ti_H ) ) iop1_ti_H = op1_ti_H - IF ( PRESENT( op1_ti_M ) ) iop1_ti_M = op1_ti_M - IF ( PRESENT( op1_ti_S ) ) iop1_ti_S = op1_ti_S - IF ( PRESENT( op1_ti_Sn ) ) iop1_ti_Sn = op1_ti_Sn - IF ( PRESENT( op1_ti_Sd ) ) iop1_ti_Sd = op1_ti_Sd - IF ( PRESENT( op2_t_YY ) ) iop2_t_YY = op2_t_YY - IF ( PRESENT( op2_t_MM ) ) iop2_t_MM = op2_t_MM - IF ( PRESENT( op2_t_DD ) ) iop2_t_DD = op2_t_DD - IF ( PRESENT( op2_t_H ) ) iop2_t_H = op2_t_H - IF ( PRESENT( op2_t_M ) ) iop2_t_M = op2_t_M - IF ( PRESENT( op2_t_S ) ) iop2_t_S = op2_t_S - IF ( PRESENT( op2_t_Sn ) ) iop2_t_Sn = op2_t_Sn - IF ( PRESENT( op2_t_Sd ) ) iop2_t_Sd = op2_t_Sd - IF ( PRESENT( op2_ti_YY ) ) iop2_ti_YY = op2_ti_YY - IF ( PRESENT( op2_ti_MM ) ) iop2_ti_MM = op2_ti_MM - IF ( PRESENT( op2_ti_DD ) ) iop2_ti_DD = op2_ti_DD - IF ( PRESENT( op2_ti_H ) ) iop2_ti_H = op2_ti_H - IF ( PRESENT( op2_ti_M ) ) iop2_ti_M = op2_ti_M - IF ( PRESENT( op2_ti_S ) ) iop2_ti_S = op2_ti_S - IF ( PRESENT( op2_ti_Sn ) ) iop2_ti_Sn = op2_ti_Sn - IF ( PRESENT( op2_ti_Sd ) ) iop2_ti_Sd = op2_ti_Sd - IF ( PRESENT( res_t_YY ) ) ires_t_YY = res_t_YY - IF ( PRESENT( res_t_MM ) ) ires_t_MM = res_t_MM - IF ( PRESENT( res_t_DD ) ) ires_t_DD = res_t_DD - IF ( PRESENT( res_t_H ) ) ires_t_H = res_t_H - IF ( PRESENT( res_t_M ) ) ires_t_M = res_t_M - IF ( PRESENT( res_t_S ) ) ires_t_S = res_t_S - IF ( PRESENT( res_t_Sn ) ) ires_t_Sn = res_t_Sn - IF ( PRESENT( res_t_Sd ) ) ires_t_Sd = res_t_Sd - IF ( PRESENT( res_ti_YY ) ) ires_ti_YY = res_ti_YY - IF ( PRESENT( res_ti_MM ) ) ires_ti_MM = res_ti_MM - IF ( PRESENT( res_ti_DD ) ) ires_ti_DD = res_ti_DD - IF ( PRESENT( res_ti_H ) ) ires_ti_H = res_ti_H - IF ( PRESENT( res_ti_M ) ) ires_ti_M = res_ti_M - IF ( PRESENT( res_ti_S ) ) ires_ti_S = res_ti_S - IF ( PRESENT( res_ti_Sn ) ) ires_ti_Sn = res_ti_Sn - IF ( PRESENT( res_ti_Sd ) ) ires_ti_Sd = res_ti_Sd - IF ( PRESENT( testname ) ) itestname = TRIM(testname) - IF ( PRESENT( expect_error ) ) iexpect_error = expect_error - - ! Ensure that optional arguments are consistent... - op1_is_t = ( PRESENT( op1_t_YY ) .OR. PRESENT( op1_t_MM ) .OR. & - PRESENT( op1_t_DD ) .OR. PRESENT( op1_t_H ) .OR. & - PRESENT( op1_t_M ) .OR. PRESENT( op1_t_S ) .OR. & - PRESENT( op1_t_Sn ) .OR. PRESENT( op1_t_Sd ) ) - op1_is_ti = ( PRESENT( op1_ti_YY ) .OR. PRESENT( op1_ti_MM ) .OR. & - PRESENT( op1_ti_DD ) .OR. PRESENT( op1_ti_H ) .OR. & - PRESENT( op1_ti_M ) .OR. PRESENT( op1_ti_S ) .OR. & - PRESENT( op1_ti_Sn ) .OR. PRESENT( op1_ti_Sd ) ) - op2_is_t = ( PRESENT( op2_t_YY ) .OR. PRESENT( op2_t_MM ) .OR. & - PRESENT( op2_t_DD ) .OR. PRESENT( op2_t_H ) .OR. & - PRESENT( op2_t_M ) .OR. PRESENT( op2_t_S ) .OR. & - PRESENT( op2_t_Sn ) .OR. PRESENT( op2_t_Sd ) ) - op2_is_ti = ( PRESENT( op2_ti_YY ) .OR. PRESENT( op2_ti_MM ) .OR. & - PRESENT( op2_ti_DD ) .OR. PRESENT( op2_ti_H ) .OR. & - PRESENT( op2_ti_M ) .OR. PRESENT( op2_ti_S ) .OR. & - PRESENT( op2_ti_Sn ) .OR. PRESENT( op2_ti_Sd ) ) - op2_is_int = ( PRESENT( op2_int ) ) - res_is_t = ( PRESENT( res_t_YY ) .OR. PRESENT( res_t_MM ) .OR. & - PRESENT( res_t_DD ) .OR. PRESENT( res_t_H ) .OR. & - PRESENT( res_t_M ) .OR. PRESENT( res_t_S ) .OR. & - PRESENT( res_t_Sn ) .OR. PRESENT( res_t_Sd ) ) - res_is_ti = ( PRESENT( res_ti_YY ) .OR. PRESENT( res_ti_MM ) .OR. & - PRESENT( res_ti_DD ) .OR. PRESENT( res_ti_H ) .OR. & - PRESENT( res_ti_M ) .OR. PRESENT( res_ti_S ) .OR. & - PRESENT( res_ti_Sn ) .OR. PRESENT( res_ti_Sd ) ) - res_is_int = ( PRESENT( res_int ) ) - num_op1 = 0 - IF ( op1_is_t ) num_op1 = num_op1 + 1 - IF ( op1_is_ti ) num_op1 = num_op1 + 1 - IF ( num_op1 /= 1 ) THEN - CALL wrf_error_fatal3( __FILE__ , __LINE__ , & - 'ERROR test_arithmetic: inconsistent args for op1' ) - ENDIF - num_op2 = 0 - IF ( op2_is_t ) num_op2 = num_op2 + 1 - IF ( op2_is_ti ) num_op2 = num_op2 + 1 - IF ( op2_is_int ) num_op2 = num_op2 + 1 - IF ( num_op2 /= 1 ) THEN - CALL wrf_error_fatal3( __FILE__ , __LINE__ , & - 'ERROR test_arithmetic: inconsistent args for op2' ) - ENDIF - num_res = 0 - IF ( res_is_t ) num_res = num_res + 1 - IF ( res_is_ti ) num_res = num_res + 1 - IF ( res_is_int ) num_res = num_res + 1 - IF ( num_res /= 1 ) THEN - CALL wrf_error_fatal3( __FILE__ , __LINE__ , & - 'ERROR test_arithmetic: inconsistent args for result' ) - ENDIF - - ! Initialize op1 - IF ( op1_is_t ) THEN - op1_type_str = 'ESMF_Time' - CALL ESMF_TimeSet( op1_t, YY=iop1_t_YY, MM=iop1_t_MM, DD=iop1_t_DD , & - H=iop1_t_H, M=iop1_t_M, S=iop1_t_S, Sn=iop1_t_Sn, Sd=iop1_t_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeSet() ', & - __FILE__ , & - __LINE__ ) - CALL ESMF_TimeGet( op1_t, timeString=op1_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - op1_str = TRIM(op1_str)//TRIM(frac_str) - ELSE - op1_type_str = 'ESMF_TimeInterval' - CALL ESMF_TimeIntervalSet( op1_ti, YY=iop1_ti_YY, MM=iop1_ti_MM, & - D=iop1_ti_DD , & - H=iop1_ti_H, M=iop1_ti_M, & - S=iop1_ti_S, Sn=iop1_ti_Sn, Sd=iop1_ti_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeIntervalSet() ', & - __FILE__ , & - __LINE__ ) - CALL ESMF_TimeIntervalGet( op1_ti, timeString=op1_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - op1_str = TRIM(op1_str)//TRIM(frac_str) - ENDIF - ! Initialize op2 - IF ( op2_is_t ) THEN - op2_type_str = 'ESMF_Time' - CALL ESMF_TimeSet( op2_t, YY=iop2_t_YY, MM=iop2_t_MM, DD=iop2_t_DD , & - H=iop2_t_H, M=iop2_t_M, S=iop2_t_S, Sn=iop2_t_Sn, Sd=iop2_t_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeSet() ', & - __FILE__ , & - __LINE__ ) - CALL ESMF_TimeGet( op2_t, timeString=op2_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - op2_str = TRIM(op2_str)//TRIM(frac_str) - ELSE IF ( op2_is_ti ) THEN - op2_type_str = 'ESMF_TimeInterval' - CALL ESMF_TimeIntervalSet( op2_ti, YY=iop2_ti_YY, MM=iop2_ti_MM, & - D=iop2_ti_DD , & - H=iop2_ti_H, M=iop2_ti_M, & - S=iop2_ti_S, Sn=iop2_ti_Sn, Sd=iop2_ti_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeIntervalSet() ', & - __FILE__ , & - __LINE__ ) - CALL ESMF_TimeIntervalGet( op2_ti, timeString=op2_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - op2_str = TRIM(op2_str)//TRIM(frac_str) - ELSE - op2_type_str = 'INTEGER' - IF ( op2_int > 0 ) THEN - WRITE(op2_str,FMT="('+',I8.8)") ABS(op2_int) - ELSE - WRITE(op2_str,FMT="('-',I8.8)") ABS(op2_int) - ENDIF - ENDIF - ! Initialize res - IF ( res_is_t ) THEN ! result is ESMF_Time - res_type_str = 'ESMF_Time' - CALL ESMF_TimeSet( res_t, YY=ires_t_YY, MM=ires_t_MM, DD=ires_t_DD , & - H=ires_t_H, M=ires_t_M, S=ires_t_S, Sn=ires_t_Sn, Sd=ires_t_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeSet() ', & - __FILE__ , & - __LINE__ ) - CALL ESMF_TimeGet( res_t, timeString=res_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - res_str = TRIM(res_str)//TRIM(frac_str) - ELSE IF ( res_is_ti ) THEN ! result is ESMF_TimeInterval - res_type_str = 'ESMF_TimeInterval' - CALL ESMF_TimeIntervalSet( res_ti, YY=ires_ti_YY, MM=ires_ti_MM, & - D=ires_ti_DD , & - H=ires_ti_H, M=ires_ti_M, & - S=ires_ti_S, Sn=ires_ti_Sn, Sd=ires_ti_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeIntervalSet() ', & - __FILE__ , & - __LINE__ ) - CALL ESMF_TimeIntervalGet( res_ti, timeString=res_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - res_str = TRIM(res_str)//TRIM(frac_str) - ELSE ! result is INTEGER - res_type_str = 'INTEGER' - IF ( res_int > 0 ) THEN - WRITE(res_str,FMT="('+',I8.8)") ABS(res_int) - ELSE - WRITE(res_str,FMT="('-',I8.8)") ABS(res_int) - ENDIF - ENDIF - - ! perform requested operation - unsupported_op = .FALSE. - ! modify behavior of wrf_error_fatal3 for operator being tested - IF ( iexpect_error ) WRF_ERROR_FATAL_PRINT = .TRUE. - ! add - IF ( iadd_op ) THEN - op_str = '+' - IF ( res_is_t ) THEN ! result is ESMF_Time - IF ( op1_is_t .AND. op2_is_ti ) THEN - ! ESMF_Time = ESMF_Time + ESMF_TimeInterval - computed_t = op1_t + op2_ti - ELSE IF ( op1_is_ti .AND. op2_is_t ) THEN - ! ESMF_Time = ESMF_TimeInterval + ESMF_Time - computed_t = op1_ti + op2_t - ELSE - unsupported_op = .TRUE. - ENDIF - ELSE ! result is ESMF_TimeInterval - IF ( op1_is_ti .AND. op2_is_ti ) THEN - ! ESMF_TimeInterval = ESMF_TimeInterval + ESMF_TimeInterval - computed_ti = op1_ti + op2_ti - ELSE - unsupported_op = .TRUE. - ENDIF - ENDIF - ! subtract - ELSE IF ( isubtract_op ) THEN - op_str = '-' - IF ( res_is_t ) THEN ! result is ESMF_Time - IF ( op1_is_t .AND. op2_is_ti ) THEN - ! ESMF_Time = ESMF_Time - ESMF_TimeInterval - computed_t = op1_t - op2_ti - ELSE - unsupported_op = .TRUE. - ENDIF - ELSE ! result is ESMF_TimeInterval - IF ( op1_is_t .AND. op2_is_t ) THEN - ! ESMF_TimeInterval = ESMF_Time - ESMF_Time - computed_ti = op1_t - op2_t - ELSE IF ( op1_is_ti .AND. op2_is_ti ) THEN - ! ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval - computed_ti = op1_ti - op2_ti - ELSE - unsupported_op = .TRUE. - ENDIF - ENDIF - ELSE IF ( imultiply_op ) THEN - op_str = '*' - IF ( res_is_ti ) THEN ! result is ESMF_TimeInterval - IF ( op1_is_ti .AND. op2_is_int ) THEN - ! ESMF_TimeInterval = ESMF_TimeInterval * INTEGER - computed_ti = op1_ti * op2_int - ELSE - unsupported_op = .TRUE. - ENDIF - ENDIF - ELSE IF ( idivide_op ) THEN - op_str = '/' - IF ( res_is_ti ) THEN ! result is ESMF_TimeInterval - IF ( op1_is_ti .AND. op2_is_int ) THEN - ! ESMF_TimeInterval = ESMF_TimeInterval / INTEGER - computed_ti = op1_ti / op2_int - ELSE - unsupported_op = .TRUE. - ENDIF - ELSE IF ( res_is_int ) THEN ! result is INTEGER - IF ( op1_is_ti .AND. op2_is_ti ) THEN - ! INTEGER = ESMF_TimeInterval / ESMF_TimeInterval - ! number of whole time intervals - computed_int = ESMF_TimeIntervalDIVQuot( op1_ti , op2_ti ) - ELSE - unsupported_op = .TRUE. - ENDIF - ENDIF - ENDIF - ! restore default behavior of wrf_error_fatal3 - IF ( iexpect_error ) WRF_ERROR_FATAL_PRINT = .FALSE. - IF ( unsupported_op ) THEN - WRITE(str,*) 'ERROR test_arithmetic ',TRIM(itestname), & - ': unsupported operation (', & - TRIM(res_type_str),' = ',TRIM(op1_type_str),' ',TRIM(op_str),' ', & - TRIM(op2_type_str),')' - CALL wrf_error_fatal3( __FILE__ , __LINE__ , str ) - ENDIF - - ! check result - test_passed = .FALSE. - IF ( res_is_t ) THEN ! result is ESMF_Time - IF ( computed_t == res_t ) THEN - test_passed = .TRUE. - ELSE - CALL ESMF_TimeGet( computed_t, timeString=computed_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - computed_str = TRIM(computed_str)//TRIM(frac_str) - ENDIF - ELSE IF ( res_is_ti ) THEN ! result is ESMF_TimeInterval - IF ( computed_ti == res_ti ) THEN - test_passed = .TRUE. - ELSE - CALL ESMF_TimeIntervalGet( computed_ti, timeString=computed_str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - computed_str = TRIM(computed_str)//TRIM(frac_str) - ENDIF - ELSE ! result is INTEGER - IF ( computed_int == res_int ) THEN - test_passed = .TRUE. - ELSE - IF ( computed_int > 0 ) THEN - WRITE(computed_str,FMT="('+',I8.8)") ABS(computed_int) - ELSE - WRITE(computed_str,FMT="('-',I8.8)") ABS(computed_int) - ENDIF - ENDIF - ENDIF - IF ( test_passed ) THEN - WRITE(*,FMT='(A)') 'PASS: '//TRIM(itestname) - ELSE - WRITE(*,*) 'FAIL: ',TRIM(itestname),': (', & - TRIM(res_type_str),' = ',TRIM(op1_type_str),' ',TRIM(op_str),' ', & - TRIM(op2_type_str),') expected ', & - TRIM(res_str),' = ',TRIM(op1_str),' ',TRIM(op_str),' ', & - TRIM(op2_str),' but computed ',TRIM(computed_str) - ENDIF - - END SUBROUTINE test_arithmetic - - - - ! simple clock creation and advance with add-subtract tests thrown in - ! no self checks (yet) - SUBROUTINE test_clock_advance( & - start_yy, start_mm, start_dd, start_h, start_m, start_s, & - stop_yy, stop_mm, stop_dd, stop_h, stop_m, stop_s, & - timestep_d, timestep_h, timestep_m, timestep_s, timestep_sn, timestep_sd, & - testname, increment_S, increment_Sn, increment_Sd ) - INTEGER, INTENT(IN), OPTIONAL :: start_YY - INTEGER, INTENT(IN), OPTIONAL :: start_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: start_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: start_H - INTEGER, INTENT(IN), OPTIONAL :: start_M - INTEGER, INTENT(IN), OPTIONAL :: start_S - INTEGER, INTENT(IN), OPTIONAL :: stop_YY - INTEGER, INTENT(IN), OPTIONAL :: stop_MM ! month - INTEGER, INTENT(IN), OPTIONAL :: stop_DD ! day of month - INTEGER, INTENT(IN), OPTIONAL :: stop_H - INTEGER, INTENT(IN), OPTIONAL :: stop_M - INTEGER, INTENT(IN), OPTIONAL :: stop_S - INTEGER, INTENT(IN), OPTIONAL :: timestep_D ! day - INTEGER, INTENT(IN), OPTIONAL :: timestep_H - INTEGER, INTENT(IN), OPTIONAL :: timestep_M - INTEGER, INTENT(IN), OPTIONAL :: timestep_S - INTEGER, INTENT(IN), OPTIONAL :: timestep_Sn - INTEGER, INTENT(IN), OPTIONAL :: timestep_Sd - CHARACTER (LEN=*), OPTIONAL, INTENT(IN) :: testname - INTEGER, INTENT(IN), OPTIONAL :: increment_S ! add and subtract this - INTEGER, INTENT(IN), OPTIONAL :: increment_Sn ! value each time step - INTEGER, INTENT(IN), OPTIONAL :: increment_Sd - - ! locals - INTEGER :: istart_YY - INTEGER :: istart_MM ! month - INTEGER :: istart_DD ! day of month - INTEGER :: istart_H - INTEGER :: istart_M - INTEGER :: istart_S - INTEGER :: istop_YY - INTEGER :: istop_MM ! month - INTEGER :: istop_DD ! day of month - INTEGER :: istop_H - INTEGER :: istop_M - INTEGER :: istop_S - INTEGER :: itimestep_D ! day - INTEGER :: itimestep_H - INTEGER :: itimestep_M - INTEGER :: itimestep_S - INTEGER :: itimestep_Sn - INTEGER :: itimestep_Sd - CHARACTER (LEN=512) :: itestname, itestfullname - INTEGER :: iincrement_S - INTEGER :: iincrement_Sn - INTEGER :: iincrement_Sd - INTEGER :: Sn, Sd - INTEGER rc - TYPE(ESMF_Time) :: start_time, stop_time, current_time - TYPE(ESMF_Clock), POINTER :: domain_clock - TYPE(ESMF_TimeInterval) :: timestep, increment - TYPE(ESMF_Time) :: add_time, subtract_time - INTEGER :: itimestep - REAL(ESMF_KIND_R8) :: dayr8 - CHARACTER(LEN=ESMF_MAXSTR) :: str, frac_str - - istart_YY = 0 - istart_MM = 1 - istart_DD = 1 - istart_H = 0 - istart_M = 0 - istart_S = 0 - istop_YY = 0 - istop_MM = 1 - istop_DD = 1 - istop_H = 0 - istop_M = 0 - istop_S = 0 - itimestep_D = 0 - itimestep_H = 0 - itimestep_M = 0 - itimestep_S = 0 - itimestep_Sn = 0 - itimestep_Sd = 0 - itestname = '' - iincrement_S = 0 - iincrement_Sn = 0 - iincrement_Sd = 0 - - IF ( PRESENT( start_YY ) ) istart_YY = start_YY - IF ( PRESENT( start_MM ) ) istart_MM = start_MM - IF ( PRESENT( start_DD ) ) istart_DD = start_DD - IF ( PRESENT( start_H ) ) istart_H = start_H - IF ( PRESENT( start_M ) ) istart_M = start_M - IF ( PRESENT( start_S ) ) istart_S = start_S - IF ( PRESENT( stop_YY ) ) istop_YY = stop_YY - IF ( PRESENT( stop_MM ) ) istop_MM = stop_MM - IF ( PRESENT( stop_DD ) ) istop_DD = stop_DD - IF ( PRESENT( stop_H ) ) istop_H = stop_H - IF ( PRESENT( stop_M ) ) istop_M = stop_M - IF ( PRESENT( stop_S ) ) istop_S = stop_S - IF ( PRESENT( timestep_D ) ) itimestep_D = timestep_D - IF ( PRESENT( timestep_H ) ) itimestep_H = timestep_H - IF ( PRESENT( timestep_M ) ) itimestep_M = timestep_M - IF ( PRESENT( timestep_S ) ) itimestep_S = timestep_S - IF ( PRESENT( timestep_Sn ) ) itimestep_Sn = timestep_Sn - IF ( PRESENT( timestep_Sd ) ) itimestep_Sd = timestep_Sd - IF ( PRESENT( testname ) ) itestname = TRIM(testname)//'_' - IF ( PRESENT( increment_S ) ) iincrement_S = increment_S - IF ( PRESENT( increment_Sn ) ) iincrement_Sn = increment_Sn - IF ( PRESENT( increment_Sd ) ) iincrement_Sd = increment_Sd - - ! Initialize start time, stop time, time step, clock for simple case. - itestfullname = TRIM(itestname)//'SETUP' - CALL ESMF_TimeSet( start_time, YY=istart_YY, MM=istart_MM, DD=istart_DD , & - H=istart_H, M=istart_M, S=istart_S, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeSet() ', & - __FILE__ , & - __LINE__ ) - - CALL ESMF_TimeGet( start_time, timeString=str, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': start_time = <',TRIM(str),'>' - - CALL ESMF_TimeSet( stop_time, YY=istop_YY, MM=istop_MM, DD=istop_DD , & - H=istop_H, M=istop_M, S=istop_S, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeSet() ', & - __FILE__ , & - __LINE__ ) - - CALL ESMF_TimeGet( stop_time, timeString=str, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': stop_time = <',TRIM(str),'>' - - CALL ESMF_TimeIntervalSet( timestep, D=itimestep_D, H=itimestep_H, & - M=itimestep_M, S=itimestep_S, & - Sn=itimestep_Sn, Sd=itimestep_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeIntervalSet() ', & - __FILE__ , & - __LINE__ ) - - CALL ESMF_TimeIntervalGet( timestep, timeString=str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeIntervalGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - str = TRIM(str)//TRIM(frac_str) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': timestep = <',TRIM(str),'>' - - CALL ESMF_TimeIntervalSet( increment, S=iincrement_S, & - Sn=iincrement_Sn, Sd=iincrement_Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeIntervalSet() ', & - __FILE__ , & - __LINE__ ) - - CALL ESMF_TimeIntervalGet( increment, timeString=str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeIntervalGet() ', & - __FILE__ , & - __LINE__ ) - ! handle fractions - CALL fraction_to_string( Sn, Sd, frac_str ) - str = TRIM(str)//TRIM(frac_str) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': increment = <',TRIM(str),'>' - - ALLOCATE( domain_clock ) - domain_clock = ESMF_ClockCreate( TimeStep= timestep, & - StartTime=start_time, & - StopTime= stop_time, & - rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_ClockCreate() ', & - __FILE__ , & - __LINE__ ) - - CALL ESMF_ClockGet( domain_clock, CurrTime=current_time, & - rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_ClockGet() ', & - __FILE__ , & - __LINE__ ) - - CALL ESMF_TimeGet( current_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - CALL fraction_to_string( Sn, Sd, frac_str ) - str = TRIM(str)//TRIM(frac_str) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': clock current_time = <',TRIM(str),'>' - - CALL ESMF_TimeGet( current_time, dayOfYear_r8=dayr8, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - WRITE(*,FMT='(A,A,F10.6,A)') TRIM(itestfullname),': current_time dayOfYear_r8 = < ',dayr8,' >' - - subtract_time = current_time - increment - CALL ESMF_TimeGet( subtract_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - CALL fraction_to_string( Sn, Sd, frac_str ) - str = TRIM(str)//TRIM(frac_str) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': current_time-increment = <',TRIM(str),'>' - - add_time = current_time + increment - CALL ESMF_TimeGet( add_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - CALL fraction_to_string( Sn, Sd, frac_str ) - str = TRIM(str)//TRIM(frac_str) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': current_time+increment = <',TRIM(str),'>' - - ! Advance clock. - itestfullname = TRIM(itestname)//'ADVANCE' - itimestep = 0 - DO WHILE ( .NOT. ESMF_ClockIsStopTime(domain_clock ,rc=rc) ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_ClockIsStopTime() ', & - __FILE__ , & - __LINE__ ) - itimestep = itimestep + 1 - - CALL ESMF_ClockAdvance( domain_clock, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_ClockAdvance() ', & - __FILE__ , & - __LINE__ ) - - CALL ESMF_ClockGet( domain_clock, CurrTime=current_time, & - rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_ClockGet() ', & - __FILE__ , & - __LINE__ ) - - CALL ESMF_TimeGet( current_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - CALL fraction_to_string( Sn, Sd, frac_str ) - str = TRIM(str)//TRIM(frac_str) - WRITE(*,FMT='(A,A,I6.6,A,A,A)') TRIM(itestfullname),': count = ', & - itimestep,' current_time = <',TRIM(str),'>' - - subtract_time = current_time - increment - CALL ESMF_TimeGet( subtract_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - CALL fraction_to_string( Sn, Sd, frac_str ) - str = TRIM(str)//TRIM(frac_str) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': current_time-increment = <',TRIM(str),'>' - - add_time = current_time + increment - CALL ESMF_TimeGet( add_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - TRIM(itestfullname)//'ESMF_TimeGet() ', & - __FILE__ , & - __LINE__ ) - CALL fraction_to_string( Sn, Sd, frac_str ) - str = TRIM(str)//TRIM(frac_str) - WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),': current_time+increment = <',TRIM(str),'>' - - ENDDO - - DEALLOCATE( domain_clock ) - - END SUBROUTINE test_clock_advance - -END MODULE my_tests - - -#if defined( TIME_F90_ONLY ) - -! TBH: Improve the build of Test1.exe to use WRF versions of these -! TBH: routines and remove these hacked-in duplicates!! - -SUBROUTINE wrf_abort - IMPLICIT NONE -#if defined( DM_PARALLEL ) && ! defined( STUBMPI ) - INCLUDE 'mpif.h' - INTEGER ierr - CALL mpi_abort(MPI_COMM_WORLD,1,ierr) -#else - STOP -#endif -END SUBROUTINE wrf_abort - -SUBROUTINE wrf_message( str ) - IMPLICIT NONE - CHARACTER*(*) str -#if defined( DM_PARALLEL ) && ! defined( STUBMPI) - write(0,*) str -#endif - print*, str -END SUBROUTINE wrf_message - -! intentionally write to stderr only -SUBROUTINE wrf_message2( str ) - IMPLICIT NONE - CHARACTER*(*) str - write(0,*) str -END SUBROUTINE wrf_message2 - -SUBROUTINE wrf_error_fatal3( file_str, line, str ) - USE my_tests - IMPLICIT NONE - CHARACTER*(*) file_str - INTEGER , INTENT (IN) :: line ! only print file and line if line > 0 - CHARACTER*(*) str - CHARACTER*256 :: line_str - write(line_str,'(i6)') line - ! special behavior for testing since Fortran cannot catch exceptions - IF ( WRF_ERROR_FATAL_PRINT ) THEN - ! just print message and continue - CALL wrf_message( 'ERROR IN FILE: '//TRIM(file_str)//' LINE: '//TRIM(line_str) ) - ELSE - ! normal behavior -#if defined( DM_PARALLEL ) && ! defined( STUBMPI ) - CALL wrf_message( '-------------- FATAL CALLED ---------------' ) - ! only print file and line if line is positive - IF ( line > 0 ) THEN - CALL wrf_message( 'FATAL CALLED FROM FILE: '//file_str//' LINE: '//TRIM(line_str) ) - ENDIF - CALL wrf_message( str ) - CALL wrf_message( '-------------------------------------------' ) -#else - CALL wrf_message2( '-------------- FATAL CALLED ---------------' ) - ! only print file and line if line is positive - IF ( line > 0 ) THEN - CALL wrf_message( 'FATAL CALLED FROM FILE: '//file_str//' LINE: '//TRIM(line_str) ) - ENDIF - CALL wrf_message2( str ) - CALL wrf_message2( '-------------------------------------------' ) -#endif - CALL wrf_abort - ENDIF -END SUBROUTINE wrf_error_fatal3 - -SUBROUTINE wrf_error_fatal( str ) - IMPLICIT NONE - CHARACTER*(*) str - CALL wrf_error_fatal3 ( ' ', 0, str ) -END SUBROUTINE wrf_error_fatal - -#endif - - -! Check to see if expected value == actual value -! If not, print message and exit. -SUBROUTINE test_check_error( expected, actual, str, file_str, line ) - IMPLICIT NONE - INTEGER , INTENT (IN) :: expected - INTEGER , INTENT (IN) :: actual - CHARACTER*(*) str - CHARACTER*(*) file_str - INTEGER , INTENT (IN) :: line - CHARACTER (LEN=512) :: rc_str - CHARACTER (LEN=512) :: str_with_rc - IF ( expected .ne. actual ) THEN - WRITE (rc_str,*) ' Routine returned error code = ',actual - str_with_rc = 'FAIL: '//TRIM(str)//TRIM(rc_str) - CALL wrf_error_fatal3( file_str, line, str_with_rc ) - ENDIF -END SUBROUTINE test_check_error - - - -PROGRAM time_manager_test - USE ESMF_Mod - USE my_tests - IMPLICIT NONE - INTEGER :: rc - - PRINT *,'BEGIN TEST SUITE' - - CALL ESMF_Initialize( defaultCalendar=ESMF_CAL_GREGORIAN, rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - 'ESMF_Initialize() ', & - __FILE__ , & - __LINE__ ) -! PRINT *,'DEBUG: back from ESMF_Initialize(), rc = ',rc - -! CALL test_print( t_yy, t_mm, t_dd, t_h, t_m, t_s, & -! ti_yy, ti_mm, ti_dd, ti_h, ti_m, ti_s, & -! res_str, testname ) - - ! Print times - ! "vanilla" tests -! PRINT *,'DEBUG: calling 1st test_print()' - CALL test_print( t_yy=2001, t_mm=12, t_dd=3, t_h=1, t_m=20, t_s=10, & - res_str='2001-12-03_01:20:10', testname='printT_1' ) -! PRINT *,'DEBUG: back from 1st test_print()' - CALL test_print( t_yy=0, t_mm=1, t_dd=1, t_h=0, t_m=0, t_s=0, & - res_str='0000-01-01_00:00:00', testname='printT_2' ) - CALL test_print( t_yy=2003, t_mm=12, t_dd=30, t_h=23, t_m=59, t_s=50, & - res_str='2003-12-30_23:59:50', testname='printT_3' ) - CALL test_print( t_yy=2003, t_mm=12, t_dd=31, t_h=23, t_m=59, t_s=50, & - res_str='2003-12-31_23:59:50', testname='printT_4' ) - CALL test_print( t_yy=2004, t_mm=12, t_dd=30, t_h=23, t_m=59, t_s=50, & - res_str='2004-12-30_23:59:50', testname='printT_5' ) - CALL test_print( t_yy=2004, t_mm=12, t_dd=31, t_h=23, t_m=59, t_s=50, & - res_str='2004-12-31_23:59:50', testname='printT_6' ) -!$$$ NOTE that this fails -- need to fix up output string for negative year -! CALL test_print( t_yy=-2004, t_mm=12, t_dd=31, t_h=23, t_m=59, t_s=50, & -! res_str='-2004-12-31_23:59:50', testname='printT_6' ) - - ! these test default behavior of test harness - CALL test_print( t_s=0, & - res_str='0000-01-01_00:00:00', testname='printT_D1' ) - CALL test_print( t_yy=0, & - res_str='0000-01-01_00:00:00', testname='printT_D2' ) - - ! fractions - CALL test_print( t_yy=2001, t_mm=12, t_dd=3, t_h=1, t_m=20, t_s=10, & - t_sn=1, t_sd=3, & - res_str='2001-12-03_01:20:10+01/03', testname='printT_F1' ) - CALL test_print( t_yy=2001, t_mm=12, t_dd=3, t_h=1, t_m=20, t_s=10, & - t_sn=4, t_sd=3, & - res_str='2001-12-03_01:20:11+01/03', testname='printT_F2' ) - CALL test_print( t_yy=2001, t_mm=12, t_dd=3, t_h=1, t_m=20, t_s=10, & - t_sn=12, t_sd=3, & - res_str='2001-12-03_01:20:14', testname='printT_F3' ) - CALL test_print( t_yy=2001, t_mm=12, t_dd=3, t_h=1, t_m=20, t_s=10, & - t_sn=-1, t_sd=3, & - res_str='2001-12-03_01:20:09+02/03', testname='printT_F4' ) - - ! ERROR, MM out of range -!$$$here... fix so this just prints "ERROR: " in failure case -!$$$here... also need "expect_fail" to reverse sense of PASS/FAIL message for -!$$$here... tests that should fail -! CALL test_print( t_yy=2001, t_mm=13, t_dd=3, t_h=1, t_m=20, t_s=10, & -! res_str='2002-01-03_01:20:10', testname='printT_E1', expect_error=.TRUE. ) - - ! Print time intervals - ! "vanilla" tests - CALL test_print( ti_yy=0, ti_mm=0, ti_dd=0, ti_h=0, ti_m=0, ti_s=0, & - res_str='0000000000_000:000:000', testname='printTI_1' ) - CALL test_print( ti_yy=0, ti_mm=0, ti_dd=500, ti_h=0, ti_m=0, ti_s=7270, & - res_str='0000000500_002:001:010', testname='printTI_2' ) - - ! these test default behavior of test harness - CALL test_print( ti_s=0, & - res_str='0000000000_000:000:000', testname='printTI_D1' ) - CALL test_print( ti_yy=0, & - res_str='0000000000_000:000:000', testname='printTI_D2' ) - - ! these test negative values - CALL test_print( ti_yy=0000, ti_mm=0, ti_dd=-3, ti_h=-1, ti_m=-20, ti_s=-10, & - res_str='-0000000003_001:020:010', testname='printTI_N1' ) - - ! these test mixed values - CALL test_print( ti_yy=0000, ti_mm=0, ti_dd=-3, ti_h=1, ti_m=20, ti_s=10, & - res_str='-0000000002_022:039:050', testname='printTI_M1' ) - - ! fractions - CALL test_print( ti_yy=0000, ti_mm=0, ti_dd=3, ti_h=1, ti_m=20, ti_s=10, & - ti_sn=1, ti_sd=3, & - res_str='0000000003_001:020:010+01/03', testname='printTI_F1' ) - CALL test_print( ti_yy=0000, ti_mm=0, ti_dd=3, ti_h=1, ti_m=20, ti_s=10, & - ti_sn=5, ti_sd=3, & - res_str='0000000003_001:020:011+02/03', testname='printTI_F2' ) - CALL test_print( ti_yy=0000, ti_mm=0, ti_dd=-3, ti_h=-1, ti_m=-20, ti_s=-10, & - ti_sn=-1, ti_sd=3, & - res_str='-0000000003_001:020:010-01/03', testname='printTI_F3' ) - CALL test_print( ti_yy=0000, ti_mm=0, ti_dd=-3, ti_h=-1, ti_m=-20, ti_s=-10, & - ti_sn=1, ti_sd=3, & - res_str='-0000000003_001:020:009-02/03', testname='printTI_F4' ) - - ! these test non-normalized values -! CALL test_print( ti_yy=2001, ti_mm=1, ti_dd=3, ti_h=1, ti_m=20, ti_s=10, & -! res_str='02001-001-003_001:020:010', testname='printTI_NN1', expect_error=.TRUE. ) -! CALL test_print( ti_yy=2001, ti_mm=12, ti_dd=3, ti_h=1, ti_m=20, ti_s=10, & -! res_str='02002-000-003_001:020:010', testname='printTI_NN2', expect_error=.TRUE. ) -! CALL test_print( ti_yy=2002, ti_mm=5, ti_dd=500, ti_h=0, ti_m=0, ti_s=7270, & -! res_str='02002-005-500_002:001:010', testname='printTI_NN3', expect_error=.TRUE. ) - - ! Addition tests - ! ESMF_Time = ESMF_Time + ESMF_TimeInterval - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2001, op1_t_mm=12, op1_t_dd=3, op1_t_h=1, op1_t_m=20, op1_t_s=10, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=3, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2001, res_t_mm=12, res_t_dd=3, res_t_h=4, res_t_m=30, res_t_s=20, & - testname='AddT_T_TI1' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2001, op1_t_mm=12, op1_t_dd=31, op1_t_h=22, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2002, res_t_mm= 1, res_t_dd=1, res_t_h=2, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI2' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2003, op1_t_mm=12, op1_t_dd=31, op1_t_h=22, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2004, res_t_mm= 1, res_t_dd=1, res_t_h=2, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI3' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2004, op1_t_mm=12, op1_t_dd=31, op1_t_h=22, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2005, res_t_mm= 1, res_t_dd=1, res_t_h=2, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI4' ) - ! this case hung after the CCSM contribution - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2004, op1_t_mm=12, op1_t_dd=30, op1_t_h=22, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2004, res_t_mm=12, res_t_dd=31, res_t_h=2, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI5' ) -! NOTE: CCSM folks need to decide what it means to add "1 month" to Feb. 29. And all the -! other very similar cases. Then, write this unit test! -! CALL test_arithmetic( add_op=.TRUE., & -! op1_t_yy=2004, op1_t_mm=12, op1_t_dd=31, op1_t_h=22, op1_t_m=30, op1_t_s=00, & -! op2_ti_yy= 2, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & -! res_t_yy=2007, res_t_mm= 1, res_t_dd=1, res_t_h=2, res_t_m=40, res_t_s=10, & -! testname='AddT_T_TI6' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2004, op1_t_mm=12, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=365, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2005, res_t_mm=12, res_t_dd=30, res_t_h=8, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI7' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2004, op1_t_mm=12, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=367, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2006, res_t_mm=01, res_t_dd=01, res_t_h=8, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI8' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2003, op1_t_mm=12, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=365, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2004, res_t_mm=12, res_t_dd=29, res_t_h=8, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI9' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2003, op1_t_mm=12, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=366, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2004, res_t_mm=12, res_t_dd=30, res_t_h=8, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI10' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2003, op1_t_mm=12, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=367, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2004, res_t_mm=12, res_t_dd=31, res_t_h=8, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI11' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2003, op1_t_mm=12, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=368, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2005, res_t_mm=01, res_t_dd=01, res_t_h=8, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI12' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2004, op1_t_mm=03, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=365, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2005, res_t_mm=03, res_t_dd=30, res_t_h=8, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI13' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2004, op1_t_mm=03, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=365, op2_ti_h=22, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2005, res_t_mm=03, res_t_dd=31, res_t_h=2, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI14' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2004, op1_t_mm=03, op1_t_dd=30, op1_t_h=4, op1_t_m=30, op1_t_s=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=366, op2_ti_h=22, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2005, res_t_mm=04, res_t_dd=01, res_t_h=2, res_t_m=40, res_t_s=10, & - testname='AddT_T_TI15' ) - ! ESMF_Time = ESMF_Time + ESMF_TimeInterval with fractions - CALL test_arithmetic( add_op=.TRUE., & - op1_t_yy=2004, op1_t_mm=12, op1_t_dd=31, op1_t_h=22, op1_t_m=30, op1_t_s=00, & - op1_t_sn=01, op1_t_sd=03, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - op2_ti_sn=01, op2_ti_sd=03, & - res_t_yy=2005, res_t_mm= 1, res_t_dd=1, res_t_h=2, res_t_m=40, res_t_s=10, & - res_t_sn=02, res_t_sd=03, & - testname='AddT_T_TI_F1' ) - ! this should fail (and does) -! CALL test_arithmetic( add_op=.TRUE., & -! op1_t_yy=2004, op1_t_mm=12, op1_t_dd=31, op1_t_h=22, op1_t_m=30, op1_t_s=00, & -! op1_t_sn=01, op1_t_sd=03, & -! op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & -! op2_ti_sn=01, op2_ti_sd=03, & -! res_t_yy=2005, res_t_mm= 1, res_t_dd=1, res_t_h=2, res_t_m=40, res_t_s=10, & -! res_t_sn=01, res_t_sd=03, & -! testname='AddT_T_TI_F2' ) - ! ESMF_Time = ESMF_TimeInterval + ESMF_Time - CALL test_arithmetic( add_op=.TRUE., & - op1_ti_yy= 0, op1_ti_mm= 0, op1_ti_dd=0, op1_ti_h=3, op1_ti_m=10, op1_ti_s=10, & - op2_t_yy=2001, op2_t_mm=12, op2_t_dd=3, op2_t_h=1, op2_t_m=20, op2_t_s=10, & - res_t_yy=2001, res_t_mm=12, res_t_dd=3, res_t_h=4, res_t_m=30, res_t_s=20, & - testname='AddT_TI_T1' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_ti_yy= 0, op1_ti_mm= 0, op1_ti_dd=0, op1_ti_h=4, op1_ti_m=10, op1_ti_s=10, & - op2_t_yy=2001, op2_t_mm=12, op2_t_dd=31, op2_t_h=22, op2_t_m=30, op2_t_s=00, & - res_t_yy=2002, res_t_mm= 1, res_t_dd=1, res_t_h=2, res_t_m=40, res_t_s=10, & - testname='AddT_TI_T2' ) - ! ESMF_TimeInterval = ESMF_TimeInterval + ESMF_TimeInterval - CALL test_arithmetic( add_op=.TRUE., & - op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=3, op1_ti_h=1, op1_ti_m=20, op1_ti_s=10, & - op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=1, op2_ti_h=1, op2_ti_m=10, op2_ti_s=10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=4, res_ti_h=2, res_ti_m=30, res_ti_s=20, & - testname='AddTI_TI_TI1' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=-3, op1_ti_h=-1, op1_ti_m=-20, op1_ti_s=-10, & - op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=1, op2_ti_h=1, op2_ti_m=10, op2_ti_s=10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-2, res_ti_h=0, res_ti_m=-10, res_ti_s=00, & - testname='AddTI_TI_TI2' ) - CALL test_arithmetic( add_op=.TRUE., & - op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=-3, op1_ti_h=-1, op1_ti_m=-20, op1_ti_s=-10, & - op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=-1, op2_ti_h=-1, op2_ti_m=-10, op2_ti_s=-10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-4, res_ti_h=-2, res_ti_m=-30, res_ti_s=-20, & - testname='AddTI_TI_TI3' ) - - ! Subtraction tests - ! ESMF_Time = ESMF_Time - ESMF_TimeInterval - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2001, op1_t_mm=12, op1_t_dd=3, op1_t_h=1, op1_t_m=20, op1_t_s=10, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=3, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2001, res_t_mm=12, res_t_dd=2, res_t_h=22, res_t_m=10, res_t_s=0, & - testname='SubtractT_T_TI1' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2005, op1_t_mm=1, op1_t_dd=1, op1_t_h=0, op1_t_m=00, op1_t_s=0, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=0, op2_ti_m=00, op2_ti_s=10, & - res_t_yy=2004, res_t_mm=12, res_t_dd=31, res_t_h=23, res_t_m=59, res_t_s=50, & - testname='SubtractT_T_TI2' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2004, op1_t_mm=1, op1_t_dd=1, op1_t_h=0, op1_t_m=00, op1_t_s=0, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=0, op2_ti_m=00, op2_ti_s=10, & - res_t_yy=2003, res_t_mm=12, res_t_dd=31, res_t_h=23, res_t_m=59, res_t_s=50, & - testname='SubtractT_T_TI3' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2003, op1_t_mm=1, op1_t_dd=1, op1_t_h=0, op1_t_m=00, op1_t_s=0, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=0, op2_ti_m=00, op2_ti_s=10, & - res_t_yy=2002, res_t_mm=12, res_t_dd=31, res_t_h=23, res_t_m=59, res_t_s=50, & - testname='SubtractT_T_TI4' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2005, op1_t_mm=04, op1_t_dd=01, op1_t_h=2, op1_t_m=40, op1_t_s=10, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=366, op2_ti_h=22, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2004, res_t_mm=03, res_t_dd=30, res_t_h=4, res_t_m=30, res_t_s=00, & - testname='SubtractT_T_TI5' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2006, op1_t_mm=01, op1_t_dd=01, op1_t_h=8, op1_t_m=40, op1_t_s=10, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=367, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, & - res_t_yy=2004, res_t_mm=12, res_t_dd=30, res_t_h=4, res_t_m=30, res_t_s=00, & - testname='SubtractT_T_TI6' ) - ! ESMF_Time = ESMF_Time - ESMF_TimeInterval with fractions - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2005, op1_t_mm=01, op1_t_dd=01, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op1_t_sn=00, op1_t_sd=00, & - op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=0, op2_ti_m=00, op2_ti_s=01, & - op2_ti_sn=01, op2_ti_sd=03, & - res_t_yy=2004, res_t_mm=12, res_t_dd=31, res_t_h=23, res_t_m=59, res_t_s=58, & - res_t_sn=02, res_t_sd=03, & - testname='SubtractT_T_TI_F1' ) - ! ESMF_TimeInterval = ESMF_Time - ESMF_Time - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2001, op1_t_mm=12, op1_t_dd=3, op1_t_h=1, op1_t_m=20, op1_t_s=10, & - op2_t_yy=2001, op2_t_mm=12, op2_t_dd=1, op2_t_h=1, op2_t_m=10, op2_t_s=10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=2, res_ti_h=0, res_ti_m=10, res_ti_s=0, & - testname='SubtractTI_T_T1' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2002, op1_t_mm=1, op1_t_dd=1, op1_t_h=0, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2001, op2_t_mm=12, op2_t_dd=31, op2_t_h=23, op2_t_m=59, op2_t_s=50, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=10, & - testname='SubtractTI_T_T2' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2005, op1_t_mm=1, op1_t_dd=1, op1_t_h=0, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2004, op2_t_mm=12, op2_t_dd=31, op2_t_h=23, op2_t_m=59, op2_t_s=50, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=10, & - testname='SubtractTI_T_T3' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2003, op1_t_mm=03, op1_t_dd=01, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2003, op2_t_mm=02, op2_t_dd=28, op2_t_h=23, op2_t_m=59, op2_t_s=50, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=10, & - testname='SubtractTI_T_T4' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2004, op1_t_mm=03, op1_t_dd=01, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2004, op2_t_mm=02, op2_t_dd=28, op2_t_h=23, op2_t_m=59, op2_t_s=50, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=1, res_ti_h=0, res_ti_m=00, res_ti_s=10, & - testname='SubtractTI_T_T5' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2002, op1_t_mm=02, op1_t_dd=28, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2002, op2_t_mm=02, op2_t_dd=28, op2_t_h=00, op2_t_m=00, op2_t_s=00, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=00, & - testname='SubtractTI_T_T6' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2003, op1_t_mm=02, op1_t_dd=28, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2002, op2_t_mm=02, op2_t_dd=28, op2_t_h=00, op2_t_m=00, op2_t_s=00, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=365, res_ti_h=0, res_ti_m=00, res_ti_s=00, & - testname='SubtractTI_T_T7' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2004, op1_t_mm=02, op1_t_dd=28, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2003, op2_t_mm=02, op2_t_dd=28, op2_t_h=00, op2_t_m=00, op2_t_s=00, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=365, res_ti_h=0, res_ti_m=00, res_ti_s=00, & - testname='SubtractTI_T_T8' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2005, op1_t_mm=02, op1_t_dd=28, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2004, op2_t_mm=02, op2_t_dd=28, op2_t_h=00, op2_t_m=00, op2_t_s=00, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=366, res_ti_h=0, res_ti_m=00, res_ti_s=00, & - testname='SubtractTI_T_T9' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2003, op1_t_mm=03, op1_t_dd=01, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2002, op2_t_mm=02, op2_t_dd=28, op2_t_h=00, op2_t_m=00, op2_t_s=00, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=366, res_ti_h=0, res_ti_m=00, res_ti_s=00, & - testname='SubtractTI_T_T10' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2005, op1_t_mm=03, op1_t_dd=01, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2004, op2_t_mm=02, op2_t_dd=28, op2_t_h=00, op2_t_m=00, op2_t_s=00, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=367, res_ti_h=0, res_ti_m=00, res_ti_s=00, & - testname='SubtractTI_T_T11' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2005, op1_t_mm=03, op1_t_dd=01, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=2004, op2_t_mm=02, op2_t_dd=28, op2_t_h=23, op2_t_m=59, op2_t_s=50, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=366, res_ti_h=0, res_ti_m=00, res_ti_s=10, & - testname='SubtractTI_T_T12' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=2004, op1_t_mm=02, op1_t_dd=28, op1_t_h=23, op1_t_m=59, op1_t_s=50, & - op2_t_yy=2005, op2_t_mm=03, op2_t_dd=01, op2_t_h=00, op2_t_m=00, op2_t_s=00, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-366, res_ti_h=0, res_ti_m=00, res_ti_s=-10, & - testname='SubtractTI_T_T13' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_t_yy=-2002, op1_t_mm=02, op1_t_dd=28, op1_t_h=00, op1_t_m=00, op1_t_s=00, & - op2_t_yy=-2002, op2_t_mm=02, op2_t_dd=28, op2_t_h=00, op2_t_m=00, op2_t_s=00, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=00, & - testname='SubtractTI_T_T14' ) - ! ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval - CALL test_arithmetic( add_op=.FALSE., & - op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=3, op1_ti_h=1, op1_ti_m=20, op1_ti_s=10, & - op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=1, op2_ti_h=1, op2_ti_m=10, op2_ti_s=10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=2, res_ti_h=0, res_ti_m=10, res_ti_s=0, & - testname='SubtractTI_TI_TI1' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=3, op1_ti_h=1, op1_ti_m=20, op1_ti_s=10, & - op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=-1, op2_ti_h=-1, op2_ti_m=-10, op2_ti_s=-10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=4, res_ti_h=2, res_ti_m=30, res_ti_s=20, & - testname='SubtractTI_TI_TI2' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=-1, op1_ti_h=-1, op1_ti_m=-10, op1_ti_s=-10, & - op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=-3, op2_ti_h=-1, op2_ti_m=-20, op2_ti_s=-10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=2, res_ti_h=0, res_ti_m=10, res_ti_s=00, & - testname='SubtractTI_TI_TI3' ) - ! Negative result ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval - CALL test_arithmetic( add_op=.FALSE., & - op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=1, op1_ti_h=1, op1_ti_m=10, op1_ti_s=10, & - op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=3, op2_ti_h=1, op2_ti_m=20, op2_ti_s=10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-2, res_ti_h=0, res_ti_m=-10, res_ti_s=0, & - testname='SubtractTI_TI_TIN1' ) - CALL test_arithmetic( add_op=.FALSE., & - op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=-1, op1_ti_h=-1, op1_ti_m=-10, op1_ti_s=-10, & - op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=3, op2_ti_h=1, op2_ti_m=20, op2_ti_s=10, & - res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-4, res_ti_h=-2, res_ti_m=-30, res_ti_s=-20, & - testname='SubtractTI_TI_TIN2' ) - - ! Un-normalized ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval - ! this is an error -! CALL test_arithmetic( add_op=.FALSE., & -! op1_ti_yy=2001, op1_ti_mm=11, op1_ti_dd=3, op1_ti_h=1, op1_ti_m=20, op1_ti_s=10, & -! op2_ti_yy=2001, op2_ti_mm=11, op2_ti_dd=1, op2_ti_h=1, op2_ti_m=10, op2_ti_s=10, & -! res_ti_yy=0000, res_ti_mm=00, res_ti_dd=2, res_ti_h=0, res_ti_m=10, res_ti_s=0, & -! testname='SubtractTI_TI_TIU1', expect_error=.TRUE. ) - - ! this one should FAIL, and does -! CALL test_arithmetic( add_op=.TRUE., & -! op1_t_yy=2001, op1_t_mm=12, op1_t_dd=3, op1_t_h=1, op1_t_m=20, op1_t_s=10, & -! op2_ti_yy= 0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=3, op2_ti_m=10, op2_ti_s=10, & -! res_t_yy=2002, res_t_mm=12, res_t_dd=3, res_t_h=4, res_t_m=30, res_t_s=20, & -! testname='AddTT1' ) - - ! Multiplication tests - ! ESMF_TimeInterval = ESMF_TimeInterval * INTEGER - CALL test_arithmetic( multiply_op=.TRUE., & - op1_ti_dd=3, op1_ti_h=12, op1_ti_m=18, op1_ti_s=33, & - op2_int=2, & - res_ti_dd=6, res_ti_h=24, res_ti_m=37, res_ti_s=06, & - testname='MultiplyTI_TI_INT1' ) - CALL test_arithmetic( multiply_op=.TRUE., & - op1_ti_dd=350, op1_ti_h=23, op1_ti_m=50, op1_ti_s=50, & - op2_int=2, & - res_ti_dd=701, res_ti_h=23, res_ti_m=41, res_ti_s=40,& - testname='MultiplyTI_TI_INT2' ) - CALL test_arithmetic( multiply_op=.TRUE., & - op1_ti_s=01, op1_ti_sn=03, op1_ti_sd=04, & - op2_int=8, & - res_ti_s=14, & - testname='MultiplyTI_TI_INT3' ) - - ! Division tests - ! ESMF_TimeInterval = ESMF_TimeInterval / INTEGER - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=3, op1_ti_h=12, op1_ti_m=18, op1_ti_s=33, & - op2_int=3, & - res_ti_dd=1, res_ti_h=04, res_ti_m=06, res_ti_s=11, & - testname='DivideTI_TI_INT1' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=3, op1_ti_h=12, op1_ti_m=18, op1_ti_s=33, & - op2_int=4, & - res_ti_dd=0, res_ti_h=21, res_ti_m=04, res_ti_s=38, & - res_ti_sn=1, res_ti_sd=4, & - testname='DivideTI_TI_INT2' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_s=01, op1_ti_sn=03, op1_ti_sd=04, & - op2_int=5, & - res_ti_s=0, res_ti_sn=7, res_ti_sd=20, & - testname='DivideTI_TI_INT3' ) - ! INTEGER = ESMF_TimeInterval / ESMF_TimeInterval - ! this operator truncates to whole integers - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=3, op1_ti_h=12, op1_ti_m=18, op1_ti_s=33, & - op2_ti_dd=3, op2_ti_h=12, op2_ti_m=18, op2_ti_s=33, & - res_int=1, & - testname='DivideINT_TI_TI1' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=6, op1_ti_h=24, op1_ti_m=36, op1_ti_s=66, & - op2_ti_dd=3, op2_ti_h=12, op2_ti_m=18, op2_ti_s=33, & - res_int=2, & - testname='DivideINT_TI_TI2' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=0, op1_ti_h=00, op1_ti_m=00, op1_ti_s=00, & - op2_ti_dd=3, op2_ti_h=12, op2_ti_m=18, op2_ti_s=33, & - res_int=0, & - testname='DivideINT_TI_TI3' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=1, op1_ti_h=00, op1_ti_m=00, op1_ti_s=00, & - op2_ti_dd=0, op2_ti_h=01, op2_ti_m=00, op2_ti_s=00, & - res_int=24, & - testname='DivideINT_TI_TI4' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=1, op1_ti_h=00, op1_ti_m=00, op1_ti_s=00, & - op2_ti_dd=0, op2_ti_h=00, op2_ti_m=01, op2_ti_s=00, & - res_int=1440, & - testname='DivideINT_TI_TI5' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=1, op1_ti_h=00, op1_ti_m=00, op1_ti_s=00, & - op2_ti_dd=0, op2_ti_h=00, op2_ti_m=00, op2_ti_s=01, & - res_int=86400, & - testname='DivideINT_TI_TI6' ) - ! rounding - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=0, op1_ti_h=00, op1_ti_m=00, op1_ti_s=03, & - op2_ti_dd=0, op2_ti_h=00, op2_ti_m=00, op2_ti_s=02, & - res_int=1, & - testname='DivideINT_TI_TIR1' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=1, op1_ti_h=00, op1_ti_m=00, op1_ti_s=02, & - op2_ti_dd=1, op2_ti_h=00, op2_ti_m=00, op2_ti_s=03, & - res_int=0, & - testname='DivideINT_TI_TIR2' ) - ! fractional operands - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_m=00, op1_ti_s=00, op1_ti_sn=03, op1_ti_sd=04, & - op2_ti_m=00, op2_ti_s=00, op2_ti_sn=03, op2_ti_sd=04, & - res_int=1, & - testname='DivideINT_TI_TIF1' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_m=00, op1_ti_s=00, op1_ti_sn=06, op1_ti_sd=08, & - op2_ti_m=00, op2_ti_s=00, op2_ti_sn=03, op2_ti_sd=04, & - res_int=1, & - testname='DivideINT_TI_TIF2' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_m=00, op1_ti_s=00, op1_ti_sn=03, op1_ti_sd=04, & - op2_ti_m=00, op2_ti_s=00, op2_ti_sn=04, op2_ti_sd=03, & - res_int=0, & - testname='DivideINT_TI_TIF3' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_m=00, op1_ti_s=02, op1_ti_sn=03, op1_ti_sd=04, & - op2_ti_m=00, op2_ti_s=01, op2_ti_sn=01, op2_ti_sd=03, & - res_int=2, & - testname='DivideINT_TI_TIF4' ) - ! negative operands - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=-6, op1_ti_h=-24, op1_ti_m=-36, op1_ti_s=-66, & - op2_ti_dd=3, op2_ti_h=12, op2_ti_m=18, op2_ti_s=33, & - res_int=-2, & - testname='DivideINT_TI_TIN1' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=6, op1_ti_h=24, op1_ti_m=36, op1_ti_s=66, & - op2_ti_dd=-3, op2_ti_h=-12, op2_ti_m=-18, op2_ti_s=-33, & - res_int=-2, & - testname='DivideINT_TI_TIN2' ) - CALL test_arithmetic( multiply_op=.FALSE., & - op1_ti_dd=-6, op1_ti_h=-24, op1_ti_m=-36, op1_ti_s=-66, & - op2_ti_dd=-3, op2_ti_h=-12, op2_ti_m=-18, op2_ti_s=-33, & - res_int=2, & - testname='DivideINT_TI_TIN3' ) - -!$$$here... modify these to add self-test PASS/FAIL output - CALL test_clock_advance( & - start_yy=2002, start_mm=12, start_dd=27, start_h=3, start_m=0, start_s=0, & - stop_yy=2002, stop_mm=12, stop_dd=28, stop_h=8, stop_m=0, stop_s=0, & - timestep_d=0, timestep_h=0, timestep_m=0, timestep_s=600, & - testname="SimpleClockAdvance" ) - - CALL test_clock_advance( & - start_yy=2003, start_mm=12, start_dd=29, start_h=9, start_m=0, start_s=0, & - stop_yy=2004, stop_mm=1, stop_dd=2, stop_h=9, stop_m=0, stop_s=0, & - timestep_d=0, timestep_h=0, timestep_m=0, timestep_s=3600, & - testname="StdYearClockAdvance", increment_S=10 ) - - CALL test_clock_advance( & - start_yy=2004, start_mm=12, start_dd=29, start_h=9, start_m=0, start_s=0, & - stop_yy=2005, stop_mm=1, stop_dd=2, stop_h=9, stop_m=0, stop_s=0, & - timestep_d=0, timestep_h=0, timestep_m=0, timestep_s=3600, & - testname="LeapYearClockAdvance", increment_S=10 ) - - ! NRCM domain 3 case: 120 seconds / 9 - ! 18 timesteps through end of leap year - CALL test_clock_advance( & - start_yy=2004, start_mm=12, start_dd=31, start_h=23, start_m=58, start_s=0,& - stop_yy=2005, stop_mm=1, stop_dd=1, stop_h=0, stop_m=2, stop_s=0, & - timestep_d=0, timestep_h=0, timestep_m=0, timestep_s=13, & - timestep_sn=1, timestep_sd=3, & - testname="LeapYearFractionClockAdvance", & - increment_S=1, increment_Sn=1, increment_Sd=3 ) - - CALL ESMF_Finalize( rc=rc ) - CALL test_check_error( ESMF_SUCCESS, rc, & - 'ESMF_Finalize() ', & - __FILE__ , & - __LINE__ ) - - PRINT *,'END TEST SUITE' - -END PROGRAM time_manager_test - diff --git a/src/external/esmf_time_f90/Test1.out.correct b/src/external/esmf_time_f90/Test1.out.correct deleted file mode 100644 index a07bddbfe0..0000000000 --- a/src/external/esmf_time_f90/Test1.out.correct +++ /dev/null @@ -1,1275 +0,0 @@ - BEGIN TEST SUITE -PASS: printT_1 -PASS: printT_2 -PASS: printT_3 -PASS: printT_4 -PASS: printT_5 -PASS: printT_6 -PASS: printT_D1 -PASS: printT_D2 -PASS: printT_F1 -PASS: printT_F2 -PASS: printT_F3 -PASS: printT_F4 -PASS: printTI_1 -PASS: printTI_2 -PASS: printTI_D1 -PASS: printTI_D2 -PASS: printTI_N1 -PASS: printTI_M1 -PASS: printTI_F1 -PASS: printTI_F2 -PASS: printTI_F3 -PASS: printTI_F4 -PASS: AddT_T_TI1 -PASS: AddT_T_TI2 -PASS: AddT_T_TI3 -PASS: AddT_T_TI4 -PASS: AddT_T_TI5 -PASS: AddT_T_TI7 -PASS: AddT_T_TI8 -PASS: AddT_T_TI9 -PASS: AddT_T_TI10 -PASS: AddT_T_TI11 -PASS: AddT_T_TI12 -PASS: AddT_T_TI13 -PASS: AddT_T_TI14 -PASS: AddT_T_TI15 -PASS: AddT_T_TI_F1 -PASS: AddT_TI_T1 -PASS: AddT_TI_T2 -PASS: AddTI_TI_TI1 -PASS: AddTI_TI_TI2 -PASS: AddTI_TI_TI3 -PASS: SubtractT_T_TI1 -PASS: SubtractT_T_TI2 -PASS: SubtractT_T_TI3 -PASS: SubtractT_T_TI4 -PASS: SubtractT_T_TI5 -PASS: SubtractT_T_TI6 -PASS: SubtractT_T_TI_F1 -PASS: SubtractTI_T_T1 -PASS: SubtractTI_T_T2 -PASS: SubtractTI_T_T3 -PASS: SubtractTI_T_T4 -PASS: SubtractTI_T_T5 -PASS: SubtractTI_T_T6 -PASS: SubtractTI_T_T7 -PASS: SubtractTI_T_T8 -PASS: SubtractTI_T_T9 -PASS: SubtractTI_T_T10 -PASS: SubtractTI_T_T11 -PASS: SubtractTI_T_T12 -PASS: SubtractTI_T_T13 -PASS: SubtractTI_T_T14 -PASS: SubtractTI_TI_TI1 -PASS: SubtractTI_TI_TI2 -PASS: SubtractTI_TI_TI3 -PASS: SubtractTI_TI_TIN1 -PASS: SubtractTI_TI_TIN2 -PASS: MultiplyTI_TI_INT1 -PASS: MultiplyTI_TI_INT2 -PASS: MultiplyTI_TI_INT3 -PASS: DivideTI_TI_INT1 -PASS: DivideTI_TI_INT2 -PASS: DivideTI_TI_INT3 -PASS: DivideINT_TI_TI1 -PASS: DivideINT_TI_TI2 -PASS: DivideINT_TI_TI3 -PASS: DivideINT_TI_TI4 -PASS: DivideINT_TI_TI5 -PASS: DivideINT_TI_TI6 -PASS: DivideINT_TI_TIR1 -PASS: DivideINT_TI_TIR2 -PASS: DivideINT_TI_TIF1 -PASS: DivideINT_TI_TIF2 -PASS: DivideINT_TI_TIF3 -PASS: DivideINT_TI_TIF4 -PASS: DivideINT_TI_TIN1 -PASS: DivideINT_TI_TIN2 -PASS: DivideINT_TI_TIN3 -SimpleClockAdvance_SETUP: start_time = <2002-12-27_03:00:00> -SimpleClockAdvance_SETUP: stop_time = <2002-12-28_08:00:00> -SimpleClockAdvance_SETUP: timestep = <0000000000_000:010:000> -SimpleClockAdvance_SETUP: increment = <0000000000_000:000:000> -SimpleClockAdvance_SETUP: clock current_time = <2002-12-27_03:00:00> -SimpleClockAdvance_SETUP: current_time dayOfYear_r8 = < 361.125000 > -SimpleClockAdvance_SETUP: current_time-increment = <2002-12-27_03:00:00> -SimpleClockAdvance_SETUP: current_time+increment = <2002-12-27_03:00:00> -SimpleClockAdvance_ADVANCE: count = 000001 current_time = <2002-12-27_03:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_03:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_03:10:00> -SimpleClockAdvance_ADVANCE: count = 000002 current_time = <2002-12-27_03:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_03:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_03:20:00> -SimpleClockAdvance_ADVANCE: count = 000003 current_time = <2002-12-27_03:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_03:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_03:30:00> -SimpleClockAdvance_ADVANCE: count = 000004 current_time = <2002-12-27_03:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_03:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_03:40:00> -SimpleClockAdvance_ADVANCE: count = 000005 current_time = <2002-12-27_03:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_03:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_03:50:00> -SimpleClockAdvance_ADVANCE: count = 000006 current_time = <2002-12-27_04:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_04:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_04:00:00> -SimpleClockAdvance_ADVANCE: count = 000007 current_time = <2002-12-27_04:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_04:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_04:10:00> -SimpleClockAdvance_ADVANCE: count = 000008 current_time = <2002-12-27_04:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_04:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_04:20:00> -SimpleClockAdvance_ADVANCE: count = 000009 current_time = <2002-12-27_04:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_04:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_04:30:00> -SimpleClockAdvance_ADVANCE: count = 000010 current_time = <2002-12-27_04:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_04:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_04:40:00> -SimpleClockAdvance_ADVANCE: count = 000011 current_time = <2002-12-27_04:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_04:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_04:50:00> -SimpleClockAdvance_ADVANCE: count = 000012 current_time = <2002-12-27_05:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_05:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_05:00:00> -SimpleClockAdvance_ADVANCE: count = 000013 current_time = <2002-12-27_05:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_05:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_05:10:00> -SimpleClockAdvance_ADVANCE: count = 000014 current_time = <2002-12-27_05:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_05:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_05:20:00> -SimpleClockAdvance_ADVANCE: count = 000015 current_time = <2002-12-27_05:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_05:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_05:30:00> -SimpleClockAdvance_ADVANCE: count = 000016 current_time = <2002-12-27_05:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_05:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_05:40:00> -SimpleClockAdvance_ADVANCE: count = 000017 current_time = <2002-12-27_05:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_05:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_05:50:00> -SimpleClockAdvance_ADVANCE: count = 000018 current_time = <2002-12-27_06:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_06:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_06:00:00> -SimpleClockAdvance_ADVANCE: count = 000019 current_time = <2002-12-27_06:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_06:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_06:10:00> -SimpleClockAdvance_ADVANCE: count = 000020 current_time = <2002-12-27_06:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_06:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_06:20:00> -SimpleClockAdvance_ADVANCE: count = 000021 current_time = <2002-12-27_06:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_06:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_06:30:00> -SimpleClockAdvance_ADVANCE: count = 000022 current_time = <2002-12-27_06:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_06:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_06:40:00> -SimpleClockAdvance_ADVANCE: count = 000023 current_time = <2002-12-27_06:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_06:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_06:50:00> -SimpleClockAdvance_ADVANCE: count = 000024 current_time = <2002-12-27_07:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_07:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_07:00:00> -SimpleClockAdvance_ADVANCE: count = 000025 current_time = <2002-12-27_07:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_07:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_07:10:00> -SimpleClockAdvance_ADVANCE: count = 000026 current_time = <2002-12-27_07:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_07:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_07:20:00> -SimpleClockAdvance_ADVANCE: count = 000027 current_time = <2002-12-27_07:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_07:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_07:30:00> -SimpleClockAdvance_ADVANCE: count = 000028 current_time = <2002-12-27_07:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_07:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_07:40:00> -SimpleClockAdvance_ADVANCE: count = 000029 current_time = <2002-12-27_07:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_07:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_07:50:00> -SimpleClockAdvance_ADVANCE: count = 000030 current_time = <2002-12-27_08:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_08:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_08:00:00> -SimpleClockAdvance_ADVANCE: count = 000031 current_time = <2002-12-27_08:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_08:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_08:10:00> -SimpleClockAdvance_ADVANCE: count = 000032 current_time = <2002-12-27_08:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_08:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_08:20:00> -SimpleClockAdvance_ADVANCE: count = 000033 current_time = <2002-12-27_08:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_08:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_08:30:00> -SimpleClockAdvance_ADVANCE: count = 000034 current_time = <2002-12-27_08:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_08:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_08:40:00> -SimpleClockAdvance_ADVANCE: count = 000035 current_time = <2002-12-27_08:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_08:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_08:50:00> -SimpleClockAdvance_ADVANCE: count = 000036 current_time = <2002-12-27_09:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_09:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_09:00:00> -SimpleClockAdvance_ADVANCE: count = 000037 current_time = <2002-12-27_09:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_09:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_09:10:00> -SimpleClockAdvance_ADVANCE: count = 000038 current_time = <2002-12-27_09:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_09:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_09:20:00> -SimpleClockAdvance_ADVANCE: count = 000039 current_time = <2002-12-27_09:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_09:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_09:30:00> -SimpleClockAdvance_ADVANCE: count = 000040 current_time = <2002-12-27_09:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_09:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_09:40:00> -SimpleClockAdvance_ADVANCE: count = 000041 current_time = <2002-12-27_09:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_09:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_09:50:00> -SimpleClockAdvance_ADVANCE: count = 000042 current_time = <2002-12-27_10:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_10:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_10:00:00> -SimpleClockAdvance_ADVANCE: count = 000043 current_time = <2002-12-27_10:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_10:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_10:10:00> -SimpleClockAdvance_ADVANCE: count = 000044 current_time = <2002-12-27_10:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_10:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_10:20:00> -SimpleClockAdvance_ADVANCE: count = 000045 current_time = <2002-12-27_10:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_10:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_10:30:00> -SimpleClockAdvance_ADVANCE: count = 000046 current_time = <2002-12-27_10:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_10:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_10:40:00> -SimpleClockAdvance_ADVANCE: count = 000047 current_time = <2002-12-27_10:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_10:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_10:50:00> -SimpleClockAdvance_ADVANCE: count = 000048 current_time = <2002-12-27_11:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_11:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_11:00:00> -SimpleClockAdvance_ADVANCE: count = 000049 current_time = <2002-12-27_11:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_11:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_11:10:00> -SimpleClockAdvance_ADVANCE: count = 000050 current_time = <2002-12-27_11:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_11:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_11:20:00> -SimpleClockAdvance_ADVANCE: count = 000051 current_time = <2002-12-27_11:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_11:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_11:30:00> -SimpleClockAdvance_ADVANCE: count = 000052 current_time = <2002-12-27_11:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_11:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_11:40:00> -SimpleClockAdvance_ADVANCE: count = 000053 current_time = <2002-12-27_11:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_11:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_11:50:00> -SimpleClockAdvance_ADVANCE: count = 000054 current_time = <2002-12-27_12:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_12:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_12:00:00> -SimpleClockAdvance_ADVANCE: count = 000055 current_time = <2002-12-27_12:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_12:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_12:10:00> -SimpleClockAdvance_ADVANCE: count = 000056 current_time = <2002-12-27_12:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_12:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_12:20:00> -SimpleClockAdvance_ADVANCE: count = 000057 current_time = <2002-12-27_12:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_12:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_12:30:00> -SimpleClockAdvance_ADVANCE: count = 000058 current_time = <2002-12-27_12:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_12:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_12:40:00> -SimpleClockAdvance_ADVANCE: count = 000059 current_time = <2002-12-27_12:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_12:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_12:50:00> -SimpleClockAdvance_ADVANCE: count = 000060 current_time = <2002-12-27_13:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_13:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_13:00:00> -SimpleClockAdvance_ADVANCE: count = 000061 current_time = <2002-12-27_13:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_13:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_13:10:00> -SimpleClockAdvance_ADVANCE: count = 000062 current_time = <2002-12-27_13:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_13:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_13:20:00> -SimpleClockAdvance_ADVANCE: count = 000063 current_time = <2002-12-27_13:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_13:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_13:30:00> -SimpleClockAdvance_ADVANCE: count = 000064 current_time = <2002-12-27_13:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_13:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_13:40:00> -SimpleClockAdvance_ADVANCE: count = 000065 current_time = <2002-12-27_13:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_13:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_13:50:00> -SimpleClockAdvance_ADVANCE: count = 000066 current_time = <2002-12-27_14:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_14:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_14:00:00> -SimpleClockAdvance_ADVANCE: count = 000067 current_time = <2002-12-27_14:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_14:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_14:10:00> -SimpleClockAdvance_ADVANCE: count = 000068 current_time = <2002-12-27_14:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_14:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_14:20:00> -SimpleClockAdvance_ADVANCE: count = 000069 current_time = <2002-12-27_14:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_14:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_14:30:00> -SimpleClockAdvance_ADVANCE: count = 000070 current_time = <2002-12-27_14:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_14:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_14:40:00> -SimpleClockAdvance_ADVANCE: count = 000071 current_time = <2002-12-27_14:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_14:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_14:50:00> -SimpleClockAdvance_ADVANCE: count = 000072 current_time = <2002-12-27_15:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_15:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_15:00:00> -SimpleClockAdvance_ADVANCE: count = 000073 current_time = <2002-12-27_15:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_15:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_15:10:00> -SimpleClockAdvance_ADVANCE: count = 000074 current_time = <2002-12-27_15:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_15:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_15:20:00> -SimpleClockAdvance_ADVANCE: count = 000075 current_time = <2002-12-27_15:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_15:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_15:30:00> -SimpleClockAdvance_ADVANCE: count = 000076 current_time = <2002-12-27_15:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_15:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_15:40:00> -SimpleClockAdvance_ADVANCE: count = 000077 current_time = <2002-12-27_15:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_15:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_15:50:00> -SimpleClockAdvance_ADVANCE: count = 000078 current_time = <2002-12-27_16:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_16:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_16:00:00> -SimpleClockAdvance_ADVANCE: count = 000079 current_time = <2002-12-27_16:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_16:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_16:10:00> -SimpleClockAdvance_ADVANCE: count = 000080 current_time = <2002-12-27_16:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_16:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_16:20:00> -SimpleClockAdvance_ADVANCE: count = 000081 current_time = <2002-12-27_16:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_16:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_16:30:00> -SimpleClockAdvance_ADVANCE: count = 000082 current_time = <2002-12-27_16:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_16:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_16:40:00> -SimpleClockAdvance_ADVANCE: count = 000083 current_time = <2002-12-27_16:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_16:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_16:50:00> -SimpleClockAdvance_ADVANCE: count = 000084 current_time = <2002-12-27_17:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_17:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_17:00:00> -SimpleClockAdvance_ADVANCE: count = 000085 current_time = <2002-12-27_17:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_17:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_17:10:00> -SimpleClockAdvance_ADVANCE: count = 000086 current_time = <2002-12-27_17:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_17:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_17:20:00> -SimpleClockAdvance_ADVANCE: count = 000087 current_time = <2002-12-27_17:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_17:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_17:30:00> -SimpleClockAdvance_ADVANCE: count = 000088 current_time = <2002-12-27_17:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_17:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_17:40:00> -SimpleClockAdvance_ADVANCE: count = 000089 current_time = <2002-12-27_17:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_17:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_17:50:00> -SimpleClockAdvance_ADVANCE: count = 000090 current_time = <2002-12-27_18:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_18:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_18:00:00> -SimpleClockAdvance_ADVANCE: count = 000091 current_time = <2002-12-27_18:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_18:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_18:10:00> -SimpleClockAdvance_ADVANCE: count = 000092 current_time = <2002-12-27_18:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_18:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_18:20:00> -SimpleClockAdvance_ADVANCE: count = 000093 current_time = <2002-12-27_18:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_18:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_18:30:00> -SimpleClockAdvance_ADVANCE: count = 000094 current_time = <2002-12-27_18:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_18:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_18:40:00> -SimpleClockAdvance_ADVANCE: count = 000095 current_time = <2002-12-27_18:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_18:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_18:50:00> -SimpleClockAdvance_ADVANCE: count = 000096 current_time = <2002-12-27_19:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_19:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_19:00:00> -SimpleClockAdvance_ADVANCE: count = 000097 current_time = <2002-12-27_19:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_19:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_19:10:00> -SimpleClockAdvance_ADVANCE: count = 000098 current_time = <2002-12-27_19:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_19:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_19:20:00> -SimpleClockAdvance_ADVANCE: count = 000099 current_time = <2002-12-27_19:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_19:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_19:30:00> -SimpleClockAdvance_ADVANCE: count = 000100 current_time = <2002-12-27_19:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_19:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_19:40:00> -SimpleClockAdvance_ADVANCE: count = 000101 current_time = <2002-12-27_19:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_19:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_19:50:00> -SimpleClockAdvance_ADVANCE: count = 000102 current_time = <2002-12-27_20:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_20:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_20:00:00> -SimpleClockAdvance_ADVANCE: count = 000103 current_time = <2002-12-27_20:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_20:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_20:10:00> -SimpleClockAdvance_ADVANCE: count = 000104 current_time = <2002-12-27_20:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_20:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_20:20:00> -SimpleClockAdvance_ADVANCE: count = 000105 current_time = <2002-12-27_20:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_20:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_20:30:00> -SimpleClockAdvance_ADVANCE: count = 000106 current_time = <2002-12-27_20:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_20:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_20:40:00> -SimpleClockAdvance_ADVANCE: count = 000107 current_time = <2002-12-27_20:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_20:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_20:50:00> -SimpleClockAdvance_ADVANCE: count = 000108 current_time = <2002-12-27_21:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_21:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_21:00:00> -SimpleClockAdvance_ADVANCE: count = 000109 current_time = <2002-12-27_21:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_21:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_21:10:00> -SimpleClockAdvance_ADVANCE: count = 000110 current_time = <2002-12-27_21:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_21:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_21:20:00> -SimpleClockAdvance_ADVANCE: count = 000111 current_time = <2002-12-27_21:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_21:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_21:30:00> -SimpleClockAdvance_ADVANCE: count = 000112 current_time = <2002-12-27_21:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_21:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_21:40:00> -SimpleClockAdvance_ADVANCE: count = 000113 current_time = <2002-12-27_21:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_21:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_21:50:00> -SimpleClockAdvance_ADVANCE: count = 000114 current_time = <2002-12-27_22:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_22:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_22:00:00> -SimpleClockAdvance_ADVANCE: count = 000115 current_time = <2002-12-27_22:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_22:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_22:10:00> -SimpleClockAdvance_ADVANCE: count = 000116 current_time = <2002-12-27_22:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_22:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_22:20:00> -SimpleClockAdvance_ADVANCE: count = 000117 current_time = <2002-12-27_22:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_22:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_22:30:00> -SimpleClockAdvance_ADVANCE: count = 000118 current_time = <2002-12-27_22:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_22:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_22:40:00> -SimpleClockAdvance_ADVANCE: count = 000119 current_time = <2002-12-27_22:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_22:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_22:50:00> -SimpleClockAdvance_ADVANCE: count = 000120 current_time = <2002-12-27_23:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_23:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_23:00:00> -SimpleClockAdvance_ADVANCE: count = 000121 current_time = <2002-12-27_23:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_23:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_23:10:00> -SimpleClockAdvance_ADVANCE: count = 000122 current_time = <2002-12-27_23:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_23:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_23:20:00> -SimpleClockAdvance_ADVANCE: count = 000123 current_time = <2002-12-27_23:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_23:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_23:30:00> -SimpleClockAdvance_ADVANCE: count = 000124 current_time = <2002-12-27_23:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_23:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_23:40:00> -SimpleClockAdvance_ADVANCE: count = 000125 current_time = <2002-12-27_23:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-27_23:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-27_23:50:00> -SimpleClockAdvance_ADVANCE: count = 000126 current_time = <2002-12-28_00:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_00:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_00:00:00> -SimpleClockAdvance_ADVANCE: count = 000127 current_time = <2002-12-28_00:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_00:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_00:10:00> -SimpleClockAdvance_ADVANCE: count = 000128 current_time = <2002-12-28_00:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_00:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_00:20:00> -SimpleClockAdvance_ADVANCE: count = 000129 current_time = <2002-12-28_00:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_00:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_00:30:00> -SimpleClockAdvance_ADVANCE: count = 000130 current_time = <2002-12-28_00:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_00:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_00:40:00> -SimpleClockAdvance_ADVANCE: count = 000131 current_time = <2002-12-28_00:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_00:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_00:50:00> -SimpleClockAdvance_ADVANCE: count = 000132 current_time = <2002-12-28_01:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_01:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_01:00:00> -SimpleClockAdvance_ADVANCE: count = 000133 current_time = <2002-12-28_01:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_01:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_01:10:00> -SimpleClockAdvance_ADVANCE: count = 000134 current_time = <2002-12-28_01:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_01:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_01:20:00> -SimpleClockAdvance_ADVANCE: count = 000135 current_time = <2002-12-28_01:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_01:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_01:30:00> -SimpleClockAdvance_ADVANCE: count = 000136 current_time = <2002-12-28_01:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_01:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_01:40:00> -SimpleClockAdvance_ADVANCE: count = 000137 current_time = <2002-12-28_01:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_01:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_01:50:00> -SimpleClockAdvance_ADVANCE: count = 000138 current_time = <2002-12-28_02:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_02:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_02:00:00> -SimpleClockAdvance_ADVANCE: count = 000139 current_time = <2002-12-28_02:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_02:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_02:10:00> -SimpleClockAdvance_ADVANCE: count = 000140 current_time = <2002-12-28_02:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_02:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_02:20:00> -SimpleClockAdvance_ADVANCE: count = 000141 current_time = <2002-12-28_02:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_02:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_02:30:00> -SimpleClockAdvance_ADVANCE: count = 000142 current_time = <2002-12-28_02:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_02:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_02:40:00> -SimpleClockAdvance_ADVANCE: count = 000143 current_time = <2002-12-28_02:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_02:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_02:50:00> -SimpleClockAdvance_ADVANCE: count = 000144 current_time = <2002-12-28_03:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_03:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_03:00:00> -SimpleClockAdvance_ADVANCE: count = 000145 current_time = <2002-12-28_03:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_03:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_03:10:00> -SimpleClockAdvance_ADVANCE: count = 000146 current_time = <2002-12-28_03:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_03:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_03:20:00> -SimpleClockAdvance_ADVANCE: count = 000147 current_time = <2002-12-28_03:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_03:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_03:30:00> -SimpleClockAdvance_ADVANCE: count = 000148 current_time = <2002-12-28_03:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_03:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_03:40:00> -SimpleClockAdvance_ADVANCE: count = 000149 current_time = <2002-12-28_03:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_03:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_03:50:00> -SimpleClockAdvance_ADVANCE: count = 000150 current_time = <2002-12-28_04:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_04:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_04:00:00> -SimpleClockAdvance_ADVANCE: count = 000151 current_time = <2002-12-28_04:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_04:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_04:10:00> -SimpleClockAdvance_ADVANCE: count = 000152 current_time = <2002-12-28_04:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_04:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_04:20:00> -SimpleClockAdvance_ADVANCE: count = 000153 current_time = <2002-12-28_04:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_04:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_04:30:00> -SimpleClockAdvance_ADVANCE: count = 000154 current_time = <2002-12-28_04:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_04:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_04:40:00> -SimpleClockAdvance_ADVANCE: count = 000155 current_time = <2002-12-28_04:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_04:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_04:50:00> -SimpleClockAdvance_ADVANCE: count = 000156 current_time = <2002-12-28_05:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_05:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_05:00:00> -SimpleClockAdvance_ADVANCE: count = 000157 current_time = <2002-12-28_05:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_05:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_05:10:00> -SimpleClockAdvance_ADVANCE: count = 000158 current_time = <2002-12-28_05:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_05:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_05:20:00> -SimpleClockAdvance_ADVANCE: count = 000159 current_time = <2002-12-28_05:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_05:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_05:30:00> -SimpleClockAdvance_ADVANCE: count = 000160 current_time = <2002-12-28_05:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_05:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_05:40:00> -SimpleClockAdvance_ADVANCE: count = 000161 current_time = <2002-12-28_05:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_05:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_05:50:00> -SimpleClockAdvance_ADVANCE: count = 000162 current_time = <2002-12-28_06:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_06:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_06:00:00> -SimpleClockAdvance_ADVANCE: count = 000163 current_time = <2002-12-28_06:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_06:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_06:10:00> -SimpleClockAdvance_ADVANCE: count = 000164 current_time = <2002-12-28_06:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_06:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_06:20:00> -SimpleClockAdvance_ADVANCE: count = 000165 current_time = <2002-12-28_06:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_06:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_06:30:00> -SimpleClockAdvance_ADVANCE: count = 000166 current_time = <2002-12-28_06:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_06:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_06:40:00> -SimpleClockAdvance_ADVANCE: count = 000167 current_time = <2002-12-28_06:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_06:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_06:50:00> -SimpleClockAdvance_ADVANCE: count = 000168 current_time = <2002-12-28_07:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_07:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_07:00:00> -SimpleClockAdvance_ADVANCE: count = 000169 current_time = <2002-12-28_07:10:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_07:10:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_07:10:00> -SimpleClockAdvance_ADVANCE: count = 000170 current_time = <2002-12-28_07:20:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_07:20:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_07:20:00> -SimpleClockAdvance_ADVANCE: count = 000171 current_time = <2002-12-28_07:30:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_07:30:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_07:30:00> -SimpleClockAdvance_ADVANCE: count = 000172 current_time = <2002-12-28_07:40:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_07:40:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_07:40:00> -SimpleClockAdvance_ADVANCE: count = 000173 current_time = <2002-12-28_07:50:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_07:50:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_07:50:00> -SimpleClockAdvance_ADVANCE: count = 000174 current_time = <2002-12-28_08:00:00> -SimpleClockAdvance_ADVANCE: current_time-increment = <2002-12-28_08:00:00> -SimpleClockAdvance_ADVANCE: current_time+increment = <2002-12-28_08:00:00> -StdYearClockAdvance_SETUP: start_time = <2003-12-29_09:00:00> -StdYearClockAdvance_SETUP: stop_time = <2004-01-02_09:00:00> -StdYearClockAdvance_SETUP: timestep = <0000000000_001:000:000> -StdYearClockAdvance_SETUP: increment = <0000000000_000:000:010> -StdYearClockAdvance_SETUP: clock current_time = <2003-12-29_09:00:00> -StdYearClockAdvance_SETUP: current_time dayOfYear_r8 = < 363.375000 > -StdYearClockAdvance_SETUP: current_time-increment = <2003-12-29_08:59:50> -StdYearClockAdvance_SETUP: current_time+increment = <2003-12-29_09:00:10> -StdYearClockAdvance_ADVANCE: count = 000001 current_time = <2003-12-29_10:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_09:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_10:00:10> -StdYearClockAdvance_ADVANCE: count = 000002 current_time = <2003-12-29_11:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_10:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_11:00:10> -StdYearClockAdvance_ADVANCE: count = 000003 current_time = <2003-12-29_12:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_11:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_12:00:10> -StdYearClockAdvance_ADVANCE: count = 000004 current_time = <2003-12-29_13:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_12:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_13:00:10> -StdYearClockAdvance_ADVANCE: count = 000005 current_time = <2003-12-29_14:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_13:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_14:00:10> -StdYearClockAdvance_ADVANCE: count = 000006 current_time = <2003-12-29_15:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_14:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_15:00:10> -StdYearClockAdvance_ADVANCE: count = 000007 current_time = <2003-12-29_16:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_15:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_16:00:10> -StdYearClockAdvance_ADVANCE: count = 000008 current_time = <2003-12-29_17:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_16:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_17:00:10> -StdYearClockAdvance_ADVANCE: count = 000009 current_time = <2003-12-29_18:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_17:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_18:00:10> -StdYearClockAdvance_ADVANCE: count = 000010 current_time = <2003-12-29_19:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_18:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_19:00:10> -StdYearClockAdvance_ADVANCE: count = 000011 current_time = <2003-12-29_20:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_19:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_20:00:10> -StdYearClockAdvance_ADVANCE: count = 000012 current_time = <2003-12-29_21:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_20:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_21:00:10> -StdYearClockAdvance_ADVANCE: count = 000013 current_time = <2003-12-29_22:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_21:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_22:00:10> -StdYearClockAdvance_ADVANCE: count = 000014 current_time = <2003-12-29_23:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_22:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-29_23:00:10> -StdYearClockAdvance_ADVANCE: count = 000015 current_time = <2003-12-30_00:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-29_23:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_00:00:10> -StdYearClockAdvance_ADVANCE: count = 000016 current_time = <2003-12-30_01:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_00:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_01:00:10> -StdYearClockAdvance_ADVANCE: count = 000017 current_time = <2003-12-30_02:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_01:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_02:00:10> -StdYearClockAdvance_ADVANCE: count = 000018 current_time = <2003-12-30_03:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_02:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_03:00:10> -StdYearClockAdvance_ADVANCE: count = 000019 current_time = <2003-12-30_04:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_03:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_04:00:10> -StdYearClockAdvance_ADVANCE: count = 000020 current_time = <2003-12-30_05:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_04:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_05:00:10> -StdYearClockAdvance_ADVANCE: count = 000021 current_time = <2003-12-30_06:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_05:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_06:00:10> -StdYearClockAdvance_ADVANCE: count = 000022 current_time = <2003-12-30_07:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_06:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_07:00:10> -StdYearClockAdvance_ADVANCE: count = 000023 current_time = <2003-12-30_08:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_07:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_08:00:10> -StdYearClockAdvance_ADVANCE: count = 000024 current_time = <2003-12-30_09:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_08:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_09:00:10> -StdYearClockAdvance_ADVANCE: count = 000025 current_time = <2003-12-30_10:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_09:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_10:00:10> -StdYearClockAdvance_ADVANCE: count = 000026 current_time = <2003-12-30_11:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_10:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_11:00:10> -StdYearClockAdvance_ADVANCE: count = 000027 current_time = <2003-12-30_12:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_11:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_12:00:10> -StdYearClockAdvance_ADVANCE: count = 000028 current_time = <2003-12-30_13:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_12:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_13:00:10> -StdYearClockAdvance_ADVANCE: count = 000029 current_time = <2003-12-30_14:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_13:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_14:00:10> -StdYearClockAdvance_ADVANCE: count = 000030 current_time = <2003-12-30_15:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_14:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_15:00:10> -StdYearClockAdvance_ADVANCE: count = 000031 current_time = <2003-12-30_16:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_15:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_16:00:10> -StdYearClockAdvance_ADVANCE: count = 000032 current_time = <2003-12-30_17:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_16:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_17:00:10> -StdYearClockAdvance_ADVANCE: count = 000033 current_time = <2003-12-30_18:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_17:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_18:00:10> -StdYearClockAdvance_ADVANCE: count = 000034 current_time = <2003-12-30_19:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_18:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_19:00:10> -StdYearClockAdvance_ADVANCE: count = 000035 current_time = <2003-12-30_20:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_19:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_20:00:10> -StdYearClockAdvance_ADVANCE: count = 000036 current_time = <2003-12-30_21:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_20:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_21:00:10> -StdYearClockAdvance_ADVANCE: count = 000037 current_time = <2003-12-30_22:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_21:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_22:00:10> -StdYearClockAdvance_ADVANCE: count = 000038 current_time = <2003-12-30_23:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_22:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-30_23:00:10> -StdYearClockAdvance_ADVANCE: count = 000039 current_time = <2003-12-31_00:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-30_23:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_00:00:10> -StdYearClockAdvance_ADVANCE: count = 000040 current_time = <2003-12-31_01:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_00:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_01:00:10> -StdYearClockAdvance_ADVANCE: count = 000041 current_time = <2003-12-31_02:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_01:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_02:00:10> -StdYearClockAdvance_ADVANCE: count = 000042 current_time = <2003-12-31_03:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_02:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_03:00:10> -StdYearClockAdvance_ADVANCE: count = 000043 current_time = <2003-12-31_04:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_03:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_04:00:10> -StdYearClockAdvance_ADVANCE: count = 000044 current_time = <2003-12-31_05:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_04:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_05:00:10> -StdYearClockAdvance_ADVANCE: count = 000045 current_time = <2003-12-31_06:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_05:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_06:00:10> -StdYearClockAdvance_ADVANCE: count = 000046 current_time = <2003-12-31_07:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_06:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_07:00:10> -StdYearClockAdvance_ADVANCE: count = 000047 current_time = <2003-12-31_08:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_07:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_08:00:10> -StdYearClockAdvance_ADVANCE: count = 000048 current_time = <2003-12-31_09:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_08:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_09:00:10> -StdYearClockAdvance_ADVANCE: count = 000049 current_time = <2003-12-31_10:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_09:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_10:00:10> -StdYearClockAdvance_ADVANCE: count = 000050 current_time = <2003-12-31_11:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_10:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_11:00:10> -StdYearClockAdvance_ADVANCE: count = 000051 current_time = <2003-12-31_12:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_11:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_12:00:10> -StdYearClockAdvance_ADVANCE: count = 000052 current_time = <2003-12-31_13:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_12:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_13:00:10> -StdYearClockAdvance_ADVANCE: count = 000053 current_time = <2003-12-31_14:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_13:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_14:00:10> -StdYearClockAdvance_ADVANCE: count = 000054 current_time = <2003-12-31_15:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_14:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_15:00:10> -StdYearClockAdvance_ADVANCE: count = 000055 current_time = <2003-12-31_16:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_15:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_16:00:10> -StdYearClockAdvance_ADVANCE: count = 000056 current_time = <2003-12-31_17:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_16:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_17:00:10> -StdYearClockAdvance_ADVANCE: count = 000057 current_time = <2003-12-31_18:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_17:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_18:00:10> -StdYearClockAdvance_ADVANCE: count = 000058 current_time = <2003-12-31_19:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_18:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_19:00:10> -StdYearClockAdvance_ADVANCE: count = 000059 current_time = <2003-12-31_20:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_19:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_20:00:10> -StdYearClockAdvance_ADVANCE: count = 000060 current_time = <2003-12-31_21:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_20:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_21:00:10> -StdYearClockAdvance_ADVANCE: count = 000061 current_time = <2003-12-31_22:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_21:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_22:00:10> -StdYearClockAdvance_ADVANCE: count = 000062 current_time = <2003-12-31_23:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_22:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2003-12-31_23:00:10> -StdYearClockAdvance_ADVANCE: count = 000063 current_time = <2004-01-01_00:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2003-12-31_23:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_00:00:10> -StdYearClockAdvance_ADVANCE: count = 000064 current_time = <2004-01-01_01:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_00:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_01:00:10> -StdYearClockAdvance_ADVANCE: count = 000065 current_time = <2004-01-01_02:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_01:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_02:00:10> -StdYearClockAdvance_ADVANCE: count = 000066 current_time = <2004-01-01_03:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_02:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_03:00:10> -StdYearClockAdvance_ADVANCE: count = 000067 current_time = <2004-01-01_04:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_03:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_04:00:10> -StdYearClockAdvance_ADVANCE: count = 000068 current_time = <2004-01-01_05:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_04:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_05:00:10> -StdYearClockAdvance_ADVANCE: count = 000069 current_time = <2004-01-01_06:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_05:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_06:00:10> -StdYearClockAdvance_ADVANCE: count = 000070 current_time = <2004-01-01_07:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_06:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_07:00:10> -StdYearClockAdvance_ADVANCE: count = 000071 current_time = <2004-01-01_08:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_07:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_08:00:10> -StdYearClockAdvance_ADVANCE: count = 000072 current_time = <2004-01-01_09:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_08:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_09:00:10> -StdYearClockAdvance_ADVANCE: count = 000073 current_time = <2004-01-01_10:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_09:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_10:00:10> -StdYearClockAdvance_ADVANCE: count = 000074 current_time = <2004-01-01_11:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_10:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_11:00:10> -StdYearClockAdvance_ADVANCE: count = 000075 current_time = <2004-01-01_12:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_11:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_12:00:10> -StdYearClockAdvance_ADVANCE: count = 000076 current_time = <2004-01-01_13:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_12:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_13:00:10> -StdYearClockAdvance_ADVANCE: count = 000077 current_time = <2004-01-01_14:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_13:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_14:00:10> -StdYearClockAdvance_ADVANCE: count = 000078 current_time = <2004-01-01_15:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_14:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_15:00:10> -StdYearClockAdvance_ADVANCE: count = 000079 current_time = <2004-01-01_16:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_15:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_16:00:10> -StdYearClockAdvance_ADVANCE: count = 000080 current_time = <2004-01-01_17:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_16:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_17:00:10> -StdYearClockAdvance_ADVANCE: count = 000081 current_time = <2004-01-01_18:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_17:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_18:00:10> -StdYearClockAdvance_ADVANCE: count = 000082 current_time = <2004-01-01_19:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_18:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_19:00:10> -StdYearClockAdvance_ADVANCE: count = 000083 current_time = <2004-01-01_20:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_19:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_20:00:10> -StdYearClockAdvance_ADVANCE: count = 000084 current_time = <2004-01-01_21:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_20:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_21:00:10> -StdYearClockAdvance_ADVANCE: count = 000085 current_time = <2004-01-01_22:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_21:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_22:00:10> -StdYearClockAdvance_ADVANCE: count = 000086 current_time = <2004-01-01_23:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_22:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-01_23:00:10> -StdYearClockAdvance_ADVANCE: count = 000087 current_time = <2004-01-02_00:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-01_23:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_00:00:10> -StdYearClockAdvance_ADVANCE: count = 000088 current_time = <2004-01-02_01:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_00:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_01:00:10> -StdYearClockAdvance_ADVANCE: count = 000089 current_time = <2004-01-02_02:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_01:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_02:00:10> -StdYearClockAdvance_ADVANCE: count = 000090 current_time = <2004-01-02_03:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_02:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_03:00:10> -StdYearClockAdvance_ADVANCE: count = 000091 current_time = <2004-01-02_04:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_03:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_04:00:10> -StdYearClockAdvance_ADVANCE: count = 000092 current_time = <2004-01-02_05:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_04:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_05:00:10> -StdYearClockAdvance_ADVANCE: count = 000093 current_time = <2004-01-02_06:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_05:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_06:00:10> -StdYearClockAdvance_ADVANCE: count = 000094 current_time = <2004-01-02_07:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_06:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_07:00:10> -StdYearClockAdvance_ADVANCE: count = 000095 current_time = <2004-01-02_08:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_07:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_08:00:10> -StdYearClockAdvance_ADVANCE: count = 000096 current_time = <2004-01-02_09:00:00> -StdYearClockAdvance_ADVANCE: current_time-increment = <2004-01-02_08:59:50> -StdYearClockAdvance_ADVANCE: current_time+increment = <2004-01-02_09:00:10> -LeapYearClockAdvance_SETUP: start_time = <2004-12-29_09:00:00> -LeapYearClockAdvance_SETUP: stop_time = <2005-01-02_09:00:00> -LeapYearClockAdvance_SETUP: timestep = <0000000000_001:000:000> -LeapYearClockAdvance_SETUP: increment = <0000000000_000:000:010> -LeapYearClockAdvance_SETUP: clock current_time = <2004-12-29_09:00:00> -LeapYearClockAdvance_SETUP: current_time dayOfYear_r8 = < 364.375000 > -LeapYearClockAdvance_SETUP: current_time-increment = <2004-12-29_08:59:50> -LeapYearClockAdvance_SETUP: current_time+increment = <2004-12-29_09:00:10> -LeapYearClockAdvance_ADVANCE: count = 000001 current_time = <2004-12-29_10:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_09:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_10:00:10> -LeapYearClockAdvance_ADVANCE: count = 000002 current_time = <2004-12-29_11:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_10:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_11:00:10> -LeapYearClockAdvance_ADVANCE: count = 000003 current_time = <2004-12-29_12:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_11:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_12:00:10> -LeapYearClockAdvance_ADVANCE: count = 000004 current_time = <2004-12-29_13:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_12:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_13:00:10> -LeapYearClockAdvance_ADVANCE: count = 000005 current_time = <2004-12-29_14:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_13:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_14:00:10> -LeapYearClockAdvance_ADVANCE: count = 000006 current_time = <2004-12-29_15:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_14:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_15:00:10> -LeapYearClockAdvance_ADVANCE: count = 000007 current_time = <2004-12-29_16:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_15:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_16:00:10> -LeapYearClockAdvance_ADVANCE: count = 000008 current_time = <2004-12-29_17:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_16:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_17:00:10> -LeapYearClockAdvance_ADVANCE: count = 000009 current_time = <2004-12-29_18:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_17:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_18:00:10> -LeapYearClockAdvance_ADVANCE: count = 000010 current_time = <2004-12-29_19:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_18:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_19:00:10> -LeapYearClockAdvance_ADVANCE: count = 000011 current_time = <2004-12-29_20:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_19:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_20:00:10> -LeapYearClockAdvance_ADVANCE: count = 000012 current_time = <2004-12-29_21:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_20:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_21:00:10> -LeapYearClockAdvance_ADVANCE: count = 000013 current_time = <2004-12-29_22:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_21:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_22:00:10> -LeapYearClockAdvance_ADVANCE: count = 000014 current_time = <2004-12-29_23:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_22:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-29_23:00:10> -LeapYearClockAdvance_ADVANCE: count = 000015 current_time = <2004-12-30_00:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-29_23:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_00:00:10> -LeapYearClockAdvance_ADVANCE: count = 000016 current_time = <2004-12-30_01:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_00:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_01:00:10> -LeapYearClockAdvance_ADVANCE: count = 000017 current_time = <2004-12-30_02:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_01:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_02:00:10> -LeapYearClockAdvance_ADVANCE: count = 000018 current_time = <2004-12-30_03:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_02:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_03:00:10> -LeapYearClockAdvance_ADVANCE: count = 000019 current_time = <2004-12-30_04:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_03:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_04:00:10> -LeapYearClockAdvance_ADVANCE: count = 000020 current_time = <2004-12-30_05:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_04:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_05:00:10> -LeapYearClockAdvance_ADVANCE: count = 000021 current_time = <2004-12-30_06:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_05:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_06:00:10> -LeapYearClockAdvance_ADVANCE: count = 000022 current_time = <2004-12-30_07:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_06:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_07:00:10> -LeapYearClockAdvance_ADVANCE: count = 000023 current_time = <2004-12-30_08:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_07:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_08:00:10> -LeapYearClockAdvance_ADVANCE: count = 000024 current_time = <2004-12-30_09:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_08:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_09:00:10> -LeapYearClockAdvance_ADVANCE: count = 000025 current_time = <2004-12-30_10:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_09:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_10:00:10> -LeapYearClockAdvance_ADVANCE: count = 000026 current_time = <2004-12-30_11:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_10:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_11:00:10> -LeapYearClockAdvance_ADVANCE: count = 000027 current_time = <2004-12-30_12:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_11:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_12:00:10> -LeapYearClockAdvance_ADVANCE: count = 000028 current_time = <2004-12-30_13:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_12:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_13:00:10> -LeapYearClockAdvance_ADVANCE: count = 000029 current_time = <2004-12-30_14:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_13:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_14:00:10> -LeapYearClockAdvance_ADVANCE: count = 000030 current_time = <2004-12-30_15:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_14:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_15:00:10> -LeapYearClockAdvance_ADVANCE: count = 000031 current_time = <2004-12-30_16:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_15:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_16:00:10> -LeapYearClockAdvance_ADVANCE: count = 000032 current_time = <2004-12-30_17:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_16:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_17:00:10> -LeapYearClockAdvance_ADVANCE: count = 000033 current_time = <2004-12-30_18:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_17:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_18:00:10> -LeapYearClockAdvance_ADVANCE: count = 000034 current_time = <2004-12-30_19:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_18:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_19:00:10> -LeapYearClockAdvance_ADVANCE: count = 000035 current_time = <2004-12-30_20:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_19:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_20:00:10> -LeapYearClockAdvance_ADVANCE: count = 000036 current_time = <2004-12-30_21:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_20:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_21:00:10> -LeapYearClockAdvance_ADVANCE: count = 000037 current_time = <2004-12-30_22:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_21:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_22:00:10> -LeapYearClockAdvance_ADVANCE: count = 000038 current_time = <2004-12-30_23:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_22:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-30_23:00:10> -LeapYearClockAdvance_ADVANCE: count = 000039 current_time = <2004-12-31_00:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-30_23:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_00:00:10> -LeapYearClockAdvance_ADVANCE: count = 000040 current_time = <2004-12-31_01:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_00:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_01:00:10> -LeapYearClockAdvance_ADVANCE: count = 000041 current_time = <2004-12-31_02:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_01:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_02:00:10> -LeapYearClockAdvance_ADVANCE: count = 000042 current_time = <2004-12-31_03:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_02:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_03:00:10> -LeapYearClockAdvance_ADVANCE: count = 000043 current_time = <2004-12-31_04:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_03:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_04:00:10> -LeapYearClockAdvance_ADVANCE: count = 000044 current_time = <2004-12-31_05:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_04:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_05:00:10> -LeapYearClockAdvance_ADVANCE: count = 000045 current_time = <2004-12-31_06:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_05:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_06:00:10> -LeapYearClockAdvance_ADVANCE: count = 000046 current_time = <2004-12-31_07:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_06:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_07:00:10> -LeapYearClockAdvance_ADVANCE: count = 000047 current_time = <2004-12-31_08:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_07:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_08:00:10> -LeapYearClockAdvance_ADVANCE: count = 000048 current_time = <2004-12-31_09:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_08:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_09:00:10> -LeapYearClockAdvance_ADVANCE: count = 000049 current_time = <2004-12-31_10:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_09:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_10:00:10> -LeapYearClockAdvance_ADVANCE: count = 000050 current_time = <2004-12-31_11:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_10:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_11:00:10> -LeapYearClockAdvance_ADVANCE: count = 000051 current_time = <2004-12-31_12:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_11:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_12:00:10> -LeapYearClockAdvance_ADVANCE: count = 000052 current_time = <2004-12-31_13:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_12:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_13:00:10> -LeapYearClockAdvance_ADVANCE: count = 000053 current_time = <2004-12-31_14:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_13:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_14:00:10> -LeapYearClockAdvance_ADVANCE: count = 000054 current_time = <2004-12-31_15:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_14:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_15:00:10> -LeapYearClockAdvance_ADVANCE: count = 000055 current_time = <2004-12-31_16:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_15:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_16:00:10> -LeapYearClockAdvance_ADVANCE: count = 000056 current_time = <2004-12-31_17:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_16:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_17:00:10> -LeapYearClockAdvance_ADVANCE: count = 000057 current_time = <2004-12-31_18:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_17:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_18:00:10> -LeapYearClockAdvance_ADVANCE: count = 000058 current_time = <2004-12-31_19:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_18:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_19:00:10> -LeapYearClockAdvance_ADVANCE: count = 000059 current_time = <2004-12-31_20:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_19:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_20:00:10> -LeapYearClockAdvance_ADVANCE: count = 000060 current_time = <2004-12-31_21:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_20:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_21:00:10> -LeapYearClockAdvance_ADVANCE: count = 000061 current_time = <2004-12-31_22:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_21:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_22:00:10> -LeapYearClockAdvance_ADVANCE: count = 000062 current_time = <2004-12-31_23:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_22:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:00:10> -LeapYearClockAdvance_ADVANCE: count = 000063 current_time = <2005-01-01_00:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:00:10> -LeapYearClockAdvance_ADVANCE: count = 000064 current_time = <2005-01-01_01:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_01:00:10> -LeapYearClockAdvance_ADVANCE: count = 000065 current_time = <2005-01-01_02:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_01:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_02:00:10> -LeapYearClockAdvance_ADVANCE: count = 000066 current_time = <2005-01-01_03:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_02:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_03:00:10> -LeapYearClockAdvance_ADVANCE: count = 000067 current_time = <2005-01-01_04:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_03:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_04:00:10> -LeapYearClockAdvance_ADVANCE: count = 000068 current_time = <2005-01-01_05:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_04:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_05:00:10> -LeapYearClockAdvance_ADVANCE: count = 000069 current_time = <2005-01-01_06:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_05:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_06:00:10> -LeapYearClockAdvance_ADVANCE: count = 000070 current_time = <2005-01-01_07:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_06:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_07:00:10> -LeapYearClockAdvance_ADVANCE: count = 000071 current_time = <2005-01-01_08:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_07:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_08:00:10> -LeapYearClockAdvance_ADVANCE: count = 000072 current_time = <2005-01-01_09:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_08:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_09:00:10> -LeapYearClockAdvance_ADVANCE: count = 000073 current_time = <2005-01-01_10:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_09:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_10:00:10> -LeapYearClockAdvance_ADVANCE: count = 000074 current_time = <2005-01-01_11:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_10:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_11:00:10> -LeapYearClockAdvance_ADVANCE: count = 000075 current_time = <2005-01-01_12:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_11:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_12:00:10> -LeapYearClockAdvance_ADVANCE: count = 000076 current_time = <2005-01-01_13:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_12:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_13:00:10> -LeapYearClockAdvance_ADVANCE: count = 000077 current_time = <2005-01-01_14:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_13:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_14:00:10> -LeapYearClockAdvance_ADVANCE: count = 000078 current_time = <2005-01-01_15:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_14:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_15:00:10> -LeapYearClockAdvance_ADVANCE: count = 000079 current_time = <2005-01-01_16:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_15:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_16:00:10> -LeapYearClockAdvance_ADVANCE: count = 000080 current_time = <2005-01-01_17:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_16:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_17:00:10> -LeapYearClockAdvance_ADVANCE: count = 000081 current_time = <2005-01-01_18:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_17:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_18:00:10> -LeapYearClockAdvance_ADVANCE: count = 000082 current_time = <2005-01-01_19:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_18:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_19:00:10> -LeapYearClockAdvance_ADVANCE: count = 000083 current_time = <2005-01-01_20:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_19:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_20:00:10> -LeapYearClockAdvance_ADVANCE: count = 000084 current_time = <2005-01-01_21:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_20:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_21:00:10> -LeapYearClockAdvance_ADVANCE: count = 000085 current_time = <2005-01-01_22:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_21:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_22:00:10> -LeapYearClockAdvance_ADVANCE: count = 000086 current_time = <2005-01-01_23:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_22:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-01_23:00:10> -LeapYearClockAdvance_ADVANCE: count = 000087 current_time = <2005-01-02_00:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-01_23:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_00:00:10> -LeapYearClockAdvance_ADVANCE: count = 000088 current_time = <2005-01-02_01:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_00:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_01:00:10> -LeapYearClockAdvance_ADVANCE: count = 000089 current_time = <2005-01-02_02:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_01:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_02:00:10> -LeapYearClockAdvance_ADVANCE: count = 000090 current_time = <2005-01-02_03:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_02:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_03:00:10> -LeapYearClockAdvance_ADVANCE: count = 000091 current_time = <2005-01-02_04:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_03:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_04:00:10> -LeapYearClockAdvance_ADVANCE: count = 000092 current_time = <2005-01-02_05:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_04:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_05:00:10> -LeapYearClockAdvance_ADVANCE: count = 000093 current_time = <2005-01-02_06:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_05:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_06:00:10> -LeapYearClockAdvance_ADVANCE: count = 000094 current_time = <2005-01-02_07:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_06:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_07:00:10> -LeapYearClockAdvance_ADVANCE: count = 000095 current_time = <2005-01-02_08:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_07:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_08:00:10> -LeapYearClockAdvance_ADVANCE: count = 000096 current_time = <2005-01-02_09:00:00> -LeapYearClockAdvance_ADVANCE: current_time-increment = <2005-01-02_08:59:50> -LeapYearClockAdvance_ADVANCE: current_time+increment = <2005-01-02_09:00:10> -LeapYearFractionClockAdvance_SETUP: start_time = <2004-12-31_23:58:00> -LeapYearFractionClockAdvance_SETUP: stop_time = <2005-01-01_00:02:00> -LeapYearFractionClockAdvance_SETUP: timestep = <0000000000_000:000:013+01/03> -LeapYearFractionClockAdvance_SETUP: increment = <0000000000_000:000:001+01/03> -LeapYearFractionClockAdvance_SETUP: clock current_time = <2004-12-31_23:58:00> -LeapYearFractionClockAdvance_SETUP: current_time dayOfYear_r8 = < 366.998611 > -LeapYearFractionClockAdvance_SETUP: current_time-increment = <2004-12-31_23:57:58+02/03> -LeapYearFractionClockAdvance_SETUP: current_time+increment = <2004-12-31_23:58:01+01/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000001 current_time = <2004-12-31_23:58:13+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:58:12> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:58:14+02/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000002 current_time = <2004-12-31_23:58:26+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:58:25+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:58:28> -LeapYearFractionClockAdvance_ADVANCE: count = 000003 current_time = <2004-12-31_23:58:40> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:58:38+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:58:41+01/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000004 current_time = <2004-12-31_23:58:53+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:58:52> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:58:54+02/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000005 current_time = <2004-12-31_23:59:06+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:59:05+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:59:08> -LeapYearFractionClockAdvance_ADVANCE: count = 000006 current_time = <2004-12-31_23:59:20> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:59:18+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:59:21+01/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000007 current_time = <2004-12-31_23:59:33+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:59:32> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:59:34+02/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000008 current_time = <2004-12-31_23:59:46+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:59:45+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2004-12-31_23:59:48> -LeapYearFractionClockAdvance_ADVANCE: count = 000009 current_time = <2005-01-01_00:00:00> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2004-12-31_23:59:58+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:00:01+01/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000010 current_time = <2005-01-01_00:00:13+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:00:12> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:00:14+02/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000011 current_time = <2005-01-01_00:00:26+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:00:25+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:00:28> -LeapYearFractionClockAdvance_ADVANCE: count = 000012 current_time = <2005-01-01_00:00:40> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:00:38+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:00:41+01/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000013 current_time = <2005-01-01_00:00:53+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:00:52> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:00:54+02/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000014 current_time = <2005-01-01_00:01:06+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:01:05+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:01:08> -LeapYearFractionClockAdvance_ADVANCE: count = 000015 current_time = <2005-01-01_00:01:20> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:01:18+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:01:21+01/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000016 current_time = <2005-01-01_00:01:33+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:01:32> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:01:34+02/03> -LeapYearFractionClockAdvance_ADVANCE: count = 000017 current_time = <2005-01-01_00:01:46+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:01:45+01/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:01:48> -LeapYearFractionClockAdvance_ADVANCE: count = 000018 current_time = <2005-01-01_00:02:00> -LeapYearFractionClockAdvance_ADVANCE: current_time-increment = <2005-01-01_00:01:58+02/03> -LeapYearFractionClockAdvance_ADVANCE: current_time+increment = <2005-01-01_00:02:01+01/03> - END TEST SUITE diff --git a/src/external/esmf_time_f90/module_symbols_util.F90 b/src/external/esmf_time_f90/module_symbols_util.F90 deleted file mode 100644 index 18d61cad46..0000000000 --- a/src/external/esmf_time_f90/module_symbols_util.F90 +++ /dev/null @@ -1,126 +0,0 @@ -! -! NOTE: This file will be removed once encapsulation of bare ESMF -! calls is complete within WRF non-external source code. -! -! NOTE: This file was automatically generated by the findsymbol script -! based on WRFV2_20050512_1410. Recipe follows: -! -! 1) Run the findsymbol script on a machine that has Ruby installed to -! generate this file. Type "findsymbol -h" for help using findsymbol. -! For example: -! >> hender IN loquat:/loquat2/hender/Ruby/FortranTools/ >> findsymbol -d /users/hender/Tasks/WRF_ESMF/WRFV2_20050512_1410_WORK/WRFV2/external/esmf_time_f90 -S ESMF_ -p -g WRFU_ -o ESMF_Mod -n module_symbols_util > & ! module_symbols_util.F90 -! -! 2) Added this comment block by hand. -! - MODULE module_symbols_util - - USE ESMF_Mod, WRFU_ALARM => ESMF_ALARM - USE ESMF_Mod, WRFU_ALARMCREATE => ESMF_ALARMCREATE - USE ESMF_Mod, WRFU_ALARMDESTROY => ESMF_ALARMDESTROY - USE ESMF_Mod, WRFU_ALARMDISABLE => ESMF_ALARMDISABLE - USE ESMF_Mod, WRFU_ALARMENABLE => ESMF_ALARMENABLE - USE ESMF_Mod, WRFU_ALARMGET => ESMF_ALARMGET - USE ESMF_Mod, WRFU_ALARMISRINGING => ESMF_ALARMISRINGING - USE ESMF_Mod, WRFU_ALARMPRINT => ESMF_ALARMPRINT - USE ESMF_Mod, WRFU_ALARMRINGEROFF => ESMF_ALARMRINGEROFF - USE ESMF_Mod, WRFU_ALARMRINGERON => ESMF_ALARMRINGERON - USE ESMF_Mod, WRFU_ALARMSET => ESMF_ALARMSET - USE ESMF_Mod, WRFU_ALARMVALIDATE => ESMF_ALARMVALIDATE - USE ESMF_Mod, WRFU_ATTRIBUTE => ESMF_ATTRIBUTE - USE ESMF_Mod, WRFU_ATTRIBUTECOPY => ESMF_ATTRIBUTECOPY - USE ESMF_Mod, WRFU_ATTRIBUTECOPYALL => ESMF_ATTRIBUTECOPYALL - USE ESMF_Mod, WRFU_ATTRIBUTEGET => ESMF_ATTRIBUTEGET - USE ESMF_Mod, WRFU_ATTRIBUTEGETBYNUMBER => ESMF_ATTRIBUTEGETBYNUMBER - USE ESMF_Mod, WRFU_ATTRIBUTEGETCOUNT => ESMF_ATTRIBUTEGETCOUNT - USE ESMF_Mod, WRFU_ATTRIBUTEGETLIST => ESMF_ATTRIBUTEGETLIST - USE ESMF_Mod, WRFU_ATTRIBUTEGETNAMELIST => ESMF_ATTRIBUTEGETNAMELIST - USE ESMF_Mod, WRFU_ATTRIBUTEGETOBJECTLIST => ESMF_ATTRIBUTEGETOBJECTLIST - USE ESMF_Mod, WRFU_ATTRIBUTESET => ESMF_ATTRIBUTESET - USE ESMF_Mod, WRFU_ATTRIBUTESETLIST => ESMF_ATTRIBUTESETLIST - USE ESMF_Mod, WRFU_ATTRIBUTESETOBJECTLIST => ESMF_ATTRIBUTESETOBJECTLIST - USE ESMF_Mod, WRFU_AXISINDEX => ESMF_AXISINDEX - USE ESMF_Mod, WRFU_AXISINDEXGET => ESMF_AXISINDEXGET - USE ESMF_Mod, WRFU_BAD_POINTER => ESMF_BAD_POINTER - USE ESMF_Mod, WRFU_BASE => ESMF_BASE - USE ESMF_Mod, WRFU_BASETIME => ESMF_BASETIME - USE ESMF_Mod, WRFU_CALENDAR => ESMF_CALENDAR - USE ESMF_Mod, WRFU_CALENDARTYPE => ESMF_CALENDARTYPE - USE ESMF_Mod, WRFU_CAL_360DAY => ESMF_CAL_360DAY - USE ESMF_Mod, WRFU_CAL_GREGORIAN => ESMF_CAL_GREGORIAN - USE ESMF_Mod, WRFU_CAL_NOCALENDAR => ESMF_CAL_NOCALENDAR - USE ESMF_Mod, WRFU_CAL_NOLEAP => ESMF_CAL_NOLEAP - USE ESMF_Mod, WRFU_CLOCK => ESMF_CLOCK - USE ESMF_Mod, WRFU_CLOCKADDALARM => ESMF_CLOCKADDALARM - USE ESMF_Mod, WRFU_CLOCKADVANCE => ESMF_CLOCKADVANCE - USE ESMF_Mod, WRFU_CLOCKCREATE => ESMF_CLOCKCREATE - USE ESMF_Mod, WRFU_CLOCKDESTROY => ESMF_CLOCKDESTROY - USE ESMF_Mod, WRFU_CLOCKGET => ESMF_CLOCKGET - USE ESMF_Mod, WRFU_CLOCKGETALARMLIST => ESMF_CLOCKGETALARMLIST - USE ESMF_Mod, WRFU_CLOCKISSTOPTIME => ESMF_CLOCKISSTOPTIME - USE ESMF_Mod, WRFU_CLOCKPRINT => ESMF_CLOCKPRINT - USE ESMF_Mod, WRFU_CLOCKSET => ESMF_CLOCKSET - USE ESMF_Mod, WRFU_CLOCKSTOPTIMEDISABLE => ESMF_CLOCKSTOPTIMEDISABLE - USE ESMF_Mod, WRFU_CLOCKVALIDATE => ESMF_CLOCKVALIDATE - USE ESMF_Mod, WRFU_DATATYPE => ESMF_DATATYPE - USE ESMF_Mod, WRFU_DATATYPESTRING => ESMF_DATATYPESTRING - USE ESMF_Mod, WRFU_DATAVALUE => ESMF_DATAVALUE - USE ESMF_Mod, WRFU_DATA_CHARACTER => ESMF_DATA_CHARACTER - USE ESMF_Mod, WRFU_DATA_INTEGER => ESMF_DATA_INTEGER - USE ESMF_Mod, WRFU_DATA_LOGICAL => ESMF_DATA_LOGICAL - USE ESMF_Mod, WRFU_DATA_REAL => ESMF_DATA_REAL - USE ESMF_Mod, WRFU_FAILURE => ESMF_FAILURE - USE ESMF_Mod, WRFU_FINALIZE => ESMF_FINALIZE - USE ESMF_Mod, WRFU_FRACTION => ESMF_FRACTION - USE ESMF_Mod, WRFU_GETNAME => ESMF_GETNAME - USE ESMF_Mod, WRFU_GETPOINTER => ESMF_GETPOINTER - USE ESMF_Mod, WRFU_GRID => ESMF_GRID - USE ESMF_Mod, WRFU_GRIDCOMP => ESMF_GRIDCOMP - USE ESMF_Mod, WRFU_INITIALIZE => ESMF_INITIALIZE - USE ESMF_Mod, WRFU_ISINITIALIZED => ESMF_ISINITIALIZED - USE ESMF_Mod, WRFU_KIND_C16 => ESMF_KIND_C16 - USE ESMF_Mod, WRFU_KIND_C8 => ESMF_KIND_C8 - USE ESMF_Mod, WRFU_KIND_I1 => ESMF_KIND_I1 - USE ESMF_Mod, WRFU_KIND_I2 => ESMF_KIND_I2 - USE ESMF_Mod, WRFU_KIND_I4 => ESMF_KIND_I4 - USE ESMF_Mod, WRFU_KIND_I8 => ESMF_KIND_I8 - USE ESMF_Mod, WRFU_KIND_R4 => ESMF_KIND_R4 - USE ESMF_Mod, WRFU_KIND_R8 => ESMF_KIND_R8 - USE ESMF_Mod, WRFU_LOG => ESMF_LOG - USE ESMF_Mod, WRFU_LOGICAL => ESMF_LOGICAL - USE ESMF_Mod, WRFU_LOGWRITE => ESMF_LOGWRITE - USE ESMF_Mod, WRFU_LOG_ERROR => ESMF_LOG_ERROR - USE ESMF_Mod, WRFU_LOG_INFO => ESMF_LOG_INFO - USE ESMF_Mod, WRFU_LOG_WARNING => ESMF_LOG_WARNING - USE ESMF_Mod, WRFU_MAJOR_VERSION => ESMF_MAJOR_VERSION - USE ESMF_Mod, WRFU_MAXDECOMPDIM => ESMF_MAXDECOMPDIM - USE ESMF_Mod, WRFU_MAXDIM => ESMF_MAXDIM - USE ESMF_Mod, WRFU_MAXGRIDDIM => ESMF_MAXGRIDDIM - USE ESMF_Mod, WRFU_MAXSTR => ESMF_MAXSTR - USE ESMF_Mod, WRFU_MINOR_VERSION => ESMF_MINOR_VERSION - USE ESMF_Mod, WRFU_MSGTYPE => ESMF_MSGTYPE - USE ESMF_Mod, WRFU_NULL_POINTER => ESMF_NULL_POINTER - USE ESMF_Mod, WRFU_POINTER => ESMF_POINTER - USE ESMF_Mod, WRFU_REVISION => ESMF_REVISION - USE ESMF_Mod, WRFU_SETNAME => ESMF_SETNAME - USE ESMF_Mod, WRFU_SETNULLPOINTER => ESMF_SETNULLPOINTER - USE ESMF_Mod, WRFU_SETPOINTER => ESMF_SETPOINTER - USE ESMF_Mod, WRFU_STATE => ESMF_STATE - USE ESMF_Mod, WRFU_STATE_INVALID => ESMF_STATE_INVALID - USE ESMF_Mod, WRFU_STATUS => ESMF_STATUS - USE ESMF_Mod, WRFU_STATUSSTRING => ESMF_STATUSSTRING - USE ESMF_Mod, WRFU_SUCCESS => ESMF_SUCCESS - USE ESMF_Mod, WRFU_TIME => ESMF_TIME - USE ESMF_Mod, WRFU_TIMEEQ => ESMF_TIMEEQ - USE ESMF_Mod, WRFU_TIMEGET => ESMF_TIMEGET - USE ESMF_Mod, WRFU_TIMEINTERVAL => ESMF_TIMEINTERVAL - USE ESMF_Mod, WRFU_TIMEINTERVALABSVALUE => ESMF_TIMEINTERVALABSVALUE - USE ESMF_Mod, WRFU_TIMEINTERVALDIVQUOT => ESMF_TIMEINTERVALDIVQUOT - USE ESMF_Mod, WRFU_TIMEINTERVALGET => ESMF_TIMEINTERVALGET - USE ESMF_Mod, WRFU_TIMEINTERVALNEGABSVALUE => ESMF_TIMEINTERVALNEGABSVALUE - USE ESMF_Mod, WRFU_TIMEINTERVALSET => ESMF_TIMEINTERVALSET - USE ESMF_Mod, WRFU_TIMESET => ESMF_TIMESET - USE ESMF_Mod, WRFU_VERSION_STRING => ESMF_VERSION_STRING - USE ESMF_Mod, WRFU_VM => ESMF_VM - - END MODULE module_symbols_util - diff --git a/src/external/esmf_time_f90/module_utility.F90 b/src/external/esmf_time_f90/module_utility.F90 deleted file mode 100644 index e818cc5bb8..0000000000 --- a/src/external/esmf_time_f90/module_utility.F90 +++ /dev/null @@ -1,7 +0,0 @@ - - MODULE module_utility - - USE module_symbols_util - - END MODULE module_utility - diff --git a/src/external/esmf_time_f90/testall.csh b/src/external/esmf_time_f90/testall.csh deleted file mode 100755 index 9f8082749a..0000000000 --- a/src/external/esmf_time_f90/testall.csh +++ /dev/null @@ -1,46 +0,0 @@ -#!/bin/csh -# -# Build and run Test1.exe and compare results with known-good output -# -set selflong = $0 -set self = $selflong:t - -if ( ! -f ../../configure.wrf ) then - echo "ERROR: must run ../../configure before building esmf_time_f90 unit tests" - exit -1 -endif - -# build -set allpass = "true" -make superclean >& /dev/null -cd ../.. ; make esmf_time_f90_only >&! external/esmf_time_f90/make_tests.out ; cd external/esmf_time_f90 -# run tests for both ESMF_ and WRFU_ interfaces... -set testoutok = "Test1.out.correct" -foreach tst ( "ESMF" "WRFU" ) - set testname = "Test1_${tst}" - ./${testname}.exe >&! ${testname}.out || echo "ERROR ${testname}: failed to execute ./${testname}.exe, see make_tests.out" && exit 20 - # evaluate test results - diff ${testoutok} ${testname}.out >& /dev/null - set ok = $status - if ( $ok == 0 ) then - echo "PASS ${testname}" - else - set allpass = "false" - echo - echo "FAIL ${testname}" - echo - which xxdiff >& /dev/null - set ok = $status - if ( $ok == 0 ) then - xxdiff ${testoutok} ${testname}.out - else - diff ${testoutok} ${testname}.out - endif - endif -end -# clean up if all tests passed -if ( $allpass == "true" ) then -# make testclean >& /dev/null - make superclean >& /dev/null -endif - diff --git a/src/external/esmf_time_f90/wrf_error_fatal.F90 b/src/external/esmf_time_f90/wrf_error_fatal.F90 new file mode 100644 index 0000000000..784778d10e --- /dev/null +++ b/src/external/esmf_time_f90/wrf_error_fatal.F90 @@ -0,0 +1,9 @@ + +subroutine wrf_error_fatal(msg) +! use shr_sys_mod, only: shr_sys_abort + implicit none + character(len=*), intent(in) :: msg + write(6,*) 'wrf_error_fatal: ',trim(msg) +! call shr_sys_abort( msg ) +end subroutine wrf_error_fatal + diff --git a/src/external/esmf_time_f90/wrf_message.F90 b/src/external/esmf_time_f90/wrf_message.F90 new file mode 100644 index 0000000000..d7880d0470 --- /dev/null +++ b/src/external/esmf_time_f90/wrf_message.F90 @@ -0,0 +1,7 @@ + +SUBROUTINE wrf_message( str ) + IMPLICIT NONE + CHARACTER*(*) str + write(6,*) str +END SUBROUTINE wrf_message + diff --git a/src/framework/Makefile b/src/framework/Makefile index 05db33a8e6..464e3312f9 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -1,6 +1,6 @@ .SUFFIXES: .F .o -DEPS := $(wildcard ../core_$(CORE)/Registry.xml) +DEPS := $(shell find ../core_$(CORE)/ -type f -name "*.xml" ! -name "*processed.xml") OBJS = mpas_kind_types.o \ mpas_framework.o \ @@ -19,10 +19,16 @@ OBJS = mpas_kind_types.o \ mpas_dmpar.o \ mpas_io.o \ mpas_io_streams.o \ - mpas_io_input.o \ - mpas_io_output.o \ + mpas_bootstrapping.o \ mpas_io_units.o \ - streams.o + mpas_stream_manager.o \ + mpas_stream_list.o \ + mpas_c_interfacing.o \ + random_id.o \ + streams.o \ + pool_hash.o \ + xml_stream_parser.o \ + ../registry/ezxml/ezxml.o all: framework $(DEPS) @@ -34,15 +40,15 @@ mpas_configure.o: mpas_dmpar.o mpas_io_units.o $(DEPS) mpas_packages.o: $(DEPS) mpas_framework.o: mpas_dmpar.o \ - mpas_io_input.o \ - mpas_io_output.o \ mpas_io.o \ mpas_grid_types.o \ mpas_configure.o \ mpas_timer.o \ mpas_sort.o \ mpas_io_units.o \ - mpas_packages.o + mpas_packages.o \ + mpas_stream_manager.o \ + mpas_c_interfacing.o mpas_constants.o: mpas_kind_types.o mpas_io_units.o @@ -50,7 +56,7 @@ mpas_dmpar_types.o : mpas_kind_types.o mpas_io_units.o mpas_attlist.o: mpas_kind_types.o mpas_io_units.o -mpas_grid_types.o: mpas_kind_types.o mpas_dmpar_types.o mpas_attlist.o mpas_io_units.o mpas_packages.o $(DEPS) +mpas_grid_types.o: mpas_kind_types.o mpas_dmpar_types.o mpas_attlist.o mpas_io_units.o mpas_packages.o mpas_io_units.o pool_hash.o mpas_timekeeping.o pool_subroutines.inc duplicate_field_array.inc duplicate_field_scalar.inc $(DEPS) mpas_dmpar.o: mpas_sort.o streams.o mpas_kind_types.o mpas_grid_types.o mpas_hash.o mpas_io_units.o @@ -62,20 +68,28 @@ mpas_timer.o: mpas_kind_types.o mpas_io_units.o mpas_block_decomp.o: mpas_grid_types.o mpas_hash.o mpas_configure.o mpas_io_units.o -mpas_block_creator.o: mpas_dmpar.o mpas_hash.o mpas_sort.o mpas_configure.o mpas_io_units.o $(DEPS) +mpas_block_creator.o: mpas_dmpar.o mpas_hash.o mpas_sort.o mpas_configure.o mpas_io_units.o mpas_block_decomp.o $(DEPS) mpas_io.o: mpas_dmpar_types.o mpas_io_units.o mpas_io_streams.o: mpas_attlist.o mpas_grid_types.o mpas_timekeeping.o mpas_io.o mpas_io_units.o $(DEPS) -mpas_io_input.o: mpas_grid_types.o mpas_dmpar.o mpas_block_decomp.o mpas_block_creator.o mpas_sort.o mpas_configure.o mpas_timekeeping.o mpas_io_streams.o mpas_io_units.o $(DEPS) - -mpas_io_output.o: mpas_grid_types.o mpas_dmpar.o mpas_sort.o mpas_configure.o mpas_io_streams.o mpas_io_units.o $(DEPS) +mpas_bootstrapping.o: mpas_grid_types.o mpas_dmpar.o mpas_block_decomp.o mpas_block_creator.o mpas_sort.o mpas_configure.o mpas_timekeeping.o mpas_io_streams.o mpas_io_units.o mpas_stream_manager.o random_id.o $(DEPS) mpas_io_units.o: +mpas_stream_list.o: mpas_grid_types.o mpas_kind_types.o mpas_io_units.o mpas_io_streams.o mpas_timekeeping.o + +mpas_stream_manager.o: mpas_io_streams.o mpas_timekeeping.o mpas_grid_types.o mpas_io_units.o mpas_kind_types.o mpas_c_interfacing.o mpas_stream_list.o mpas_dmpar.o mpas_io.o + +xml_stream_parser.o: xml_stream_parser.c + $(CC) $(CFLAGS) $(CPPFLAGS) $(CPPINCLUDES) -I../registry -c xml_stream_parser.c + clean: $(RM) *.o *.mod *.f90 libframework.a + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: $(RM) $@ $*.mod diff --git a/src/framework/add_field_indices.inc b/src/framework/add_field_indices.inc index 2bb63a5dde..0296d1b808 100644 --- a/src/framework/add_field_indices.inc +++ b/src/framework/add_field_indices.inc @@ -5,8 +5,12 @@ !write(0,*) '... outer dimension is nCells' allocate(indices(0)) do while (associated(field_ptr)) - call mergeArrays(indices, field_ptr % block % mesh % indexToCellID % array(1:field_ptr % block % mesh % nCellsSolve)) - totalDimSize = totalDimSize + field_ptr % block % mesh % nCellsSolve + call mpas_pool_get_array(field_ptr % block % allFields, 'indexToCellID', indexArray) + call mpas_pool_get_dimension(field_ptr % block % dimensions, 'nCellsSolve', indexDimension) + + call mergeArrays(indices, indexArray(1:indexDimension)) + totalDimSize = totalDimSize + indexDimension + field_ptr => field_ptr % next end do call mpas_dmpar_sum_int(field % block % domain % dminfo, totalDimSize, globalDimSize) @@ -15,8 +19,12 @@ !write(0,*) '... outer dimension is nEdges' allocate(indices(0)) do while (associated(field_ptr)) - call mergeArrays(indices, field_ptr % block % mesh % indexToEdgeID % array(1:field_ptr % block % mesh % nEdgesSolve)) - totalDimSize = totalDimSize + field_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_array(field_ptr % block % allFields, 'indexToEdgeID', indexArray) + call mpas_pool_get_dimension(field_ptr % block % dimensions, 'nEdgesSolve', indexDimension) + + call mergeArrays(indices, indexArray(1:indexDimension)) + totalDimSize = totalDimSize + indexDimension + field_ptr => field_ptr % next end do call mpas_dmpar_sum_int(field % block % domain % dminfo, totalDimSize, globalDimSize) @@ -25,8 +33,12 @@ !write(0,*) '... outer dimension is nVertices' allocate(indices(0)) do while (associated(field_ptr)) - call mergeArrays(indices, field_ptr % block % mesh % indexToVertexID % array(1:field_ptr % block % mesh % nVerticesSolve)) - totalDimSize = totalDimSize + field_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_array(field_ptr % block % allFields, 'indexToVertexID', indexArray) + call mpas_pool_get_dimension(field_ptr % block % dimensions, 'nVerticesSolve', indexDimension) + + call mergeArrays(indices, indexArray(1:indexDimension)) + totalDimSize = totalDimSize + indexDimension + field_ptr => field_ptr % next end do call mpas_dmpar_sum_int(field % block % domain % dminfo, totalDimSize, globalDimSize) @@ -37,7 +49,6 @@ totalDimSize = globalDimSize if (field % block % domain % dminfo % my_proc_id == IO_NODE) then - ndims = 1 allocate(indices(field % dimSizes(ndims))) do i=1,field % dimSizes(ndims) indices(i) = i diff --git a/src/framework/duplicate_field_array.inc b/src/framework/duplicate_field_array.inc new file mode 100644 index 0000000000..223548535a --- /dev/null +++ b/src/framework/duplicate_field_array.inc @@ -0,0 +1,57 @@ + if (present(copy_array_only)) then + local_copy_only = copy_array_only + else + local_copy_only = .false. + end if + + + src_cursor => src + if (.not. local_copy_only) then + nullify(dst_cursor) + else + dst_cursor => dst + end if + +! do while (associated(src_cursor)) + + if (.not. local_copy_only) then + if (associated(dst_cursor)) then + allocate(dst_cursor % next) + dst_cursor % next % prev => dst_cursor + dst_cursor => dst_cursor % next + else + allocate(dst) + nullify(dst % prev) + dst_cursor => dst + end if + nullify(dst_cursor % next) + end if + + + ! + ! Fill in members of dst_cursor from src_cursor + ! + if (.not. local_copy_only) then + allocate(dst_cursor % ioinfo) + dst_cursor % ioinfo = src_cursor % ioinfo + dst_cursor % block => src_cursor % block + dst_cursor % fieldName = src_cursor % fieldName + dst_cursor % isVarArray = src_cursor % isVarArray + dst_cursor % isPersistent = src_cursor % isPersistent + dst_cursor % isActive = src_cursor % isActive + dst_cursor % hasTimeDimension = src_cursor % hasTimeDimension + dst_cursor % dimNames = src_cursor % dimNames + dst_cursor % dimSizes = src_cursor % dimSizes + dst_cursor % sendList => src_cursor % sendList + dst_cursor % recvList => src_cursor % recvList + dst_cursor % copyList => src_cursor % copyList + call mpas_allocate_mold(dst_cursor % array, src_cursor % array) ! Until we get F2008 support for ALLOCATE(A,MOLD=B) + end if + dst_cursor % array = src_cursor % array + +! src_cursor => src_cursor % next +! if (.not. local_copy_only) then +! dst_cursor => dst_cursor % next +! end if + +! end do diff --git a/src/framework/duplicate_field_scalar.inc b/src/framework/duplicate_field_scalar.inc new file mode 100644 index 0000000000..2fde66a8e5 --- /dev/null +++ b/src/framework/duplicate_field_scalar.inc @@ -0,0 +1,53 @@ + if (present(copy_array_only)) then + local_copy_only = copy_array_only + else + local_copy_only = .false. + end if + + + src_cursor => src + if (.not. local_copy_only) then + nullify(dst_cursor) + else + dst_cursor => dst + end if + +! do while (associated(src_cursor)) + + if (.not. local_copy_only) then + if (associated(dst_cursor)) then + allocate(dst_cursor % next) + dst_cursor % next % prev => dst_cursor + dst_cursor => dst_cursor % next + else + allocate(dst) + nullify(dst % prev) + dst_cursor => dst + end if + nullify(dst_cursor % next) + end if + + + ! + ! Fill in members of dst_cursor from src_cursor + ! + if (.not. local_copy_only) then + allocate(dst_cursor % ioinfo) + dst_cursor % ioinfo = src_cursor % ioinfo + dst_cursor % block => src_cursor % block + dst_cursor % fieldName = src_cursor % fieldName + dst_cursor % isVarArray = src_cursor % isVarArray + dst_cursor % isActive = src_cursor % isActive + dst_cursor % hasTimeDimension = src_cursor % hasTimeDimension + dst_cursor % sendList => src_cursor % sendList + dst_cursor % recvList => src_cursor % recvList + dst_cursor % copyList => src_cursor % copyList + end if + dst_cursor % scalar = src_cursor % scalar + +! src_cursor => src_cursor % next +! if (.not. local_copy_only) then +! dst_cursor => dst_cursor % next +! end if + +! end do diff --git a/src/framework/mpas_block_creator.F b/src/framework/mpas_block_creator.F index 658b7031dc..0ebb58b3ad 100644 --- a/src/framework/mpas_block_creator.F +++ b/src/framework/mpas_block_creator.F @@ -47,7 +47,8 @@ module mpas_block_creator ! !----------------------------------------------------------------------- - subroutine mpas_block_creator_setup_blocks_and_0halo_cells(domain, indexToCellID, cellList, blockID, blockStart, blockCount)!{{{ + subroutine mpas_block_creator_setup_blocks_and_0halo_cells(nHalos, domain, indexToCellID, cellList, blockID, blockStart, blockCount)!{{{ + integer, intent(in) :: nHalos !< Input: Number of halos for cell fields type (domain_type), pointer :: domain !< Input: Domain information type (field1dInteger), pointer :: indexToCellID !< Input/Output: indexToCellID field integer, dimension(:), intent(in) :: cellList !< Input: List of cell indices owned by this processor @@ -55,7 +56,6 @@ subroutine mpas_block_creator_setup_blocks_and_0halo_cells(domain, indexToCellID integer, dimension(:), intent(in) :: blockStart !< Input: Indices of starting cell id in cellList for each block integer, dimension(:), intent(in) :: blockCount !< Input: Number of cells from cellList owned by each block. - integer :: nHalos type (block_type), pointer :: blockCursor type (field1dInteger), pointer :: fieldCursor @@ -63,7 +63,6 @@ subroutine mpas_block_creator_setup_blocks_and_0halo_cells(domain, indexToCellID integer :: nBlocks nBlocks = size(blockID) - nHalos = config_num_halos ! Setup first block allocate(domain % blocklist) @@ -129,7 +128,11 @@ end subroutine mpas_block_creator_setup_blocks_and_0halo_cells!}}} ! !----------------------------------------------------------------------- - subroutine mpas_block_creator_build_0halo_cell_fields(indexToCellIDBlock, nEdgesOnCellBlock, cellsOnCellBlock, verticesOnCellBlock, edgesOnCellBlock, indexToCellID_0Halo, nEdgesOnCell_0Halo, cellsOnCell_0Halo, verticesOnCell_0Halo, edgesOnCell_0Halo)!{{{ + subroutine mpas_block_creator_build_0halo_cell_fields(nHalos, indexToCellIDBlock, & + nEdgesOnCellBlock, cellsOnCellBlock, verticesOnCellBlock, edgesOnCellBlock, & + indexToCellID_0Halo, nEdgesOnCell_0Halo, cellsOnCell_0Halo, & + verticesOnCell_0Halo, edgesOnCell_0Halo)!{{{ + integer, intent(in) :: nHalos !< Input: Number of halos for cell fields type(field1dInteger), pointer :: indexToCellIDBlock !< Input: Block of read in indexToCellID field type(field1dInteger), pointer :: nEdgesOnCellBlock !< Input: Block of read in nEdgesOnCell field type(field2dInteger), pointer :: cellsOnCellBlock !< Input: Block of read in cellsOnCell field @@ -147,9 +150,7 @@ subroutine mpas_block_creator_build_0halo_cell_fields(indexToCellIDBlock, nEdges integer, dimension(:), pointer :: sendingHaloLayers - integer :: nCellsInBlock, maxEdges, nHalos - - nHalos = config_num_halos + integer :: nCellsInBlock, maxEdges ! Only sending from halo layer 1 for setup allocate(sendingHaloLayers(1)) @@ -267,7 +268,8 @@ end subroutine mpas_block_creator_build_0halo_cell_fields!}}} ! !----------------------------------------------------------------------- - subroutine mpas_block_creator_build_0_and_1halo_edge_fields(indexToEdgeIDBlock, cellsOnEdgeBlock, indexToCellID_0Halo, nEdgesOnCell_0Halo, edgesOnCell_0Halo, indexToEdgeID_0Halo, cellsOnEdge_0Halo, nEdgesSolve)!{{{ + subroutine mpas_block_creator_build_0_and_1halo_edge_fields(nHalos, indexToEdgeIDBlock, cellsOnEdgeBlock, indexToCellID_0Halo, nEdgesOnCell_0Halo, edgesOnCell_0Halo, indexToEdgeID_0Halo, cellsOnEdge_0Halo, nEdgesSolve)!{{{ + integer, intent(in) :: nHalos !< Input: Number of halos for cell fields type (field1dInteger), pointer :: indexToEdgeIDBlock !< Input: indexToEdgeID read in field type (field2dInteger), pointer :: cellsOnEdgeBlock !< Input: cellsOnEdge read in field type (field1dInteger), pointer :: indexToCellID_0Halo !< Input: indexToCellID field on 0 halo @@ -286,7 +288,7 @@ subroutine mpas_block_creator_build_0_and_1halo_edge_fields(indexToEdgeIDBlock, integer, dimension(:), pointer :: localEdgeList integer, dimension(:), pointer :: sendingHaloLayers - integer :: nEdgesLocal, nCellsInBlock, maxEdges, edgeDegree, nHalos + integer :: nEdgesLocal, nCellsInBlock, maxEdges, edgeDegree integer :: haloStart ! Setup sendingHaloLayers @@ -296,7 +298,6 @@ subroutine mpas_block_creator_build_0_and_1halo_edge_fields(indexToEdgeIDBlock, ! Get dimension information maxEdges = edgesOnCell_0Halo % dimSizes(1) edgeDegree = cellsOnEdgeBlock % dimSizes(1) - nHalos = config_num_halos ! Setup initial block for each field allocate(cellsOnEdge_0Halo) @@ -479,7 +480,8 @@ end subroutine mpas_block_creator_build_0_and_1halo_edge_fields!}}} ! !----------------------------------------------------------------------- - subroutine mpas_block_creator_build_cell_halos(indexToCellID, nEdgesOnCell, cellsOnCell, verticesOnCell, edgesOnCell, nCellsSolve)!{{{ + subroutine mpas_block_creator_build_cell_halos(nHalos, indexToCellID, nEdgesOnCell, cellsOnCell, verticesOnCell, edgesOnCell, nCellsSolve)!{{{ + integer, intent(in) :: nHalos !< Input: Number of halos for cell fields type (field1dInteger), pointer :: indexToCellID !< Input/Output: indexToCellID field for all halos type (field1dInteger), pointer :: nEdgesOnCell !< Input/Output: nEdgesOnCell field for all halos type (field2dInteger), pointer :: cellsOnCell !< Input/Output: cellsOnCell field for all halos @@ -504,10 +506,9 @@ subroutine mpas_block_creator_build_cell_halos(indexToCellID, nEdgesOnCell, cell type (graph), pointer :: blockGraph, blockGraphWithHalo - integer :: nHalos, nCellsInBlock, nCellsInHalo, maxEdges + integer :: nCellsInBlock, nCellsInHalo, maxEdges integer :: iHalo - nHalos = config_num_halos dminfo => indexToCellID % block % domain % dminfo allocate(sendingHaloLayers(1)) @@ -747,7 +748,8 @@ end subroutine mpas_block_creator_build_cell_halos!}}} ! !----------------------------------------------------------------------- - subroutine mpas_block_creator_build_edge_halos(indexToCellID, nEdgesOnCell, nCellsSolve, edgesOnCell, indexToEdgeID, cellsOnEdge, nEdgesSolve)!{{{ + subroutine mpas_block_creator_build_edge_halos(nHalos, indexToCellID, nEdgesOnCell, nCellsSolve, edgesOnCell, indexToEdgeID, cellsOnEdge, nEdgesSolve)!{{{ + integer, intent(in) :: nHalos !< Input: Number of halos for cell fields type (field1dInteger), pointer :: indexToCellID !< Input: indexToCellID field for all halos type (field1dInteger), pointer :: nEdgesOnCell !< Input: nEdgesOnCell field for all halos type (field1dInteger), pointer :: nCellsSolve !< Input: nCellsSolve field for all halos @@ -768,13 +770,12 @@ subroutine mpas_block_creator_build_edge_halos(indexToCellID, nEdgesOnCell, nCel integer, dimension(:,:), pointer :: array2dHolder integer :: iHalo, iBlock, i, j - integer :: nHalos, nBlocks, nCellsInBlock, nEdgesLocal, haloSize + integer :: nBlocks, nCellsInBlock, nEdgesLocal, haloSize integer :: maxEdges, edgeDegree type (hashtable), dimension(:), pointer :: edgeList ! Determine dimensions - nHalos = config_num_halos maxEdges = edgesOnCell % dimSizes(1) edgeDegree = cellsOnEdge % dimSizes(1) @@ -974,11 +975,12 @@ end subroutine mpas_block_creator_build_edge_halos!}}} ! !----------------------------------------------------------------------- - subroutine mpas_block_creator_finalize_block_init(blocklist, & !{{{ + subroutine mpas_block_creator_finalize_block_init(nHalos, blocklist, & !{{{ #include "dim_dummy_args.inc" , nCellsSolve, nEdgesSolve, nVerticesSolve, indexToCellID, indexToEdgeID, indexToVertexID) + integer, intent(in) :: nHalos !< Input: Number of halos for cell fields type (block_type), pointer :: blocklist !< Input/Output: Linked List of blocks -#include "dim_dummy_decls_inout.inc" +#include "dim_dummy_defines_inout.inc" type (field1dInteger), pointer :: nCellsSolve !< Input: nCellsSolve field information type (field1dInteger), pointer :: nEdgesSolve !< Input: nEdgesSolve field information type (field1dInteger), pointer :: nVerticesSolve !< Input: nVerticesSolve field information @@ -988,15 +990,15 @@ subroutine mpas_block_creator_finalize_block_init(blocklist, & !{{{ type (domain_type), pointer :: domain + integer, dimension(:), pointer :: indexToCellIDPool, indexToEdgeIDPool, indexToVertexIDPool + type (block_type), pointer :: block_ptr type (field1dInteger), pointer :: nCellsCursor, nEdgesCursor, nVerticesCursor type (field1dInteger), pointer :: indexToCellCursor, indexToEdgeCursor, indexToVertexCursor - integer :: nHalos integer :: nCellsSolve_0Halo, nVerticesSolve_0Halo, nEdgesSolve_0Halo integer :: blockID, localBlockID - nHalos = config_num_halos domain => blocklist % domain ! Loop over blocks @@ -1026,26 +1028,31 @@ subroutine mpas_block_creator_finalize_block_init(blocklist, & !{{{ #include "dim_dummy_args.inc" ) - allocate(block_ptr % mesh % nCellsArray(0:nHalos)) - allocate(block_ptr % mesh % nEdgesArray(0:nHalos+1)) - allocate(block_ptr % mesh % nVerticesArray(0:nHalos+1)) +#include "add_dims_to_pool.inc" + + ! Set block's *Solve dimensions + call mpas_pool_add_dimension(block_ptr % dimensions, 'nCellsSolve', nCellsSolve_0Halo) + call mpas_pool_add_dimension(block_ptr % dimensions, 'nEdgesSolve', nEdgesSolve_0Halo) + call mpas_pool_add_dimension(block_ptr % dimensions, 'nVerticesSolve', nVerticesSolve_0Halo) + + call mpas_pool_add_dimension(block_ptr % dimensions, 'nCellsArray', nCellsCursor % array(:)) + call mpas_pool_add_dimension(block_ptr % dimensions, 'nEdgesArray', nEdgesCursor % array(:)) + call mpas_pool_add_dimension(block_ptr % dimensions, 'nVerticesArray', nVerticesCursor % array(:)) + + call mpas_define_derived_dimensions(block_ptr % dimensions, block_ptr % configs) - block_ptr % mesh % nCellsArray(:) = nCellsCursor % array(:) - block_ptr % mesh % nEdgesArray(:) = nEdgesCursor % array(:) - block_ptr % mesh % nVerticesArray(:) = nVerticesCursor % array(:) + call mpas_generate_structs(block_ptr, block_ptr % structs, block_ptr % dimensions, block_ptr % packages) ! Set block's local id block_ptr % localBlockID = localBlockID - ! Set block's *Solve dimensions - block_ptr % mesh % nCellsSolve = nCellsSolve_0Halo - block_ptr % mesh % nEdgesSolve = nEdgesSolve_0Halo - block_ptr % mesh % nVerticesSolve = nVerticesSolve_0Halo - ! Set block's 0 halo indices - block_ptr % mesh % indexToCellID % array(1:nCellsSolve_0Halo) = indexToCellCursor % array(1:nCellsSolve_0Halo) - block_ptr % mesh % indexToEdgeID % array(1:nEdgesSolve_0Halo) = indexToEdgeCursor % array(1:nEdgesSolve_0Halo) - block_ptr % mesh % indexToVertexID % array(1:nVerticesSolve_0Halo) = indexToVertexCursor % array(1:nVerticesSolve_0Halo) + call mpas_pool_get_array(block_ptr % allFields, 'indexToCellID', indexToCellIDPool) + call mpas_pool_get_array(block_ptr % allFields, 'indexToEdgeID', indexToEdgeIDPool) + call mpas_pool_get_array(block_ptr % allFields, 'indexToVertexID', indexToVertexIDPool) + indexToCellIDPool(1:nCellsSolve_0Halo) = indexToCellCursor % array(1:nCellsSolve_0Halo) + indexToEdgeIDPool(1:nEdgesSolve_0Halo) = indexToEdgeCursor % array(1:nEdgesSolve_0Halo) + indexToVertexIDPool(1:nVerticesSolve_0Halo) = indexToVertexCursor % array(1:nVerticesSolve_0Halo) ! Set block's exchange lists and nullify unneeded exchange lists block_ptr % parinfo % cellsToSend => indexToCellCursor % sendList @@ -1111,13 +1118,6 @@ subroutine mpas_block_creator_finalize_block_init(blocklist, & !{{{ indexToVertexCursor => indextoVertexcursor % next end do - ! Link fields between blocks - block_ptr => blocklist - do while(associated(block_ptr)) - call mpas_create_field_links(block_ptr) - - block_ptr => block_ptr % next - end do end subroutine mpas_block_creator_finalize_block_init!}}} !*********************************************************************** @@ -1143,113 +1143,131 @@ subroutine mpas_block_creator_reindex_block_fields(blocklist)!{{{ integer :: i, j, k integer, dimension(:,:), pointer :: cellIDSorted, edgeIDSorted, vertexIDSorted + integer, pointer :: nCells, nEdges, nVertices, vertexDegree + integer, dimension(:), pointer :: indexToCellID, indexToEdgeID, indexToVertexID + integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge + integer, dimension(:,:), pointer :: cellsOnCell, cellsOnVertex, cellsOnEdge + integer, dimension(:,:), pointer :: edgesOnCell, edgesOnVertex, edgesOnEdge + integer, dimension(:,:), pointer :: verticesOnCell, verticesOnEdge + ! Loop over blocks block_ptr => blocklist do while(associated(block_ptr)) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertices', nVertices) + call mpas_pool_get_dimension(block_ptr % dimensions, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(block_ptr % allFields, 'indexToCellID', indexToCellID) + call mpas_pool_get_array(block_ptr % allFields, 'indexToEdgeID', indexToEdgeID) + call mpas_pool_get_array(block_ptr % allFields, 'indexToVertexID', indexToVertexID) + call mpas_pool_get_array(block_ptr % allFields, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(block_ptr % allFields, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(block_ptr % allFields, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(block_ptr % allFields, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(block_ptr % allFields, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(block_ptr % allFields, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(block_ptr % allFields, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(block_ptr % allFields, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(block_ptr % allFields, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(block_ptr % allFields, 'edgesOnEdge', edgesOnEdge) + ! ! Rename vertices in cellsOnCell, edgesOnCell, etc. to local indices ! - allocate(cellIDSorted(2, block_ptr % mesh % nCells)) - allocate(edgeIDSorted(2, block_ptr % mesh % nEdges)) - allocate(vertexIDSorted(2, block_ptr % mesh % nVertices)) + allocate(cellIDSorted(2, nCells)) + allocate(edgeIDSorted(2, nEdges)) + allocate(vertexIDSorted(2, nVertices)) - do i=1,block_ptr % mesh % nCells - cellIDSorted(1,i) = block_ptr % mesh % indexToCellID % array(i) + do i = 1, nCells + cellIDSorted(1,i) = indexToCellID(i) cellIDSorted(2,i) = i end do - call mpas_quicksort(block_ptr % mesh % nCells, cellIDSorted) + call mpas_quicksort(nCells, cellIDSorted) - do i=1,block_ptr % mesh % nEdges - edgeIDSorted(1,i) = block_ptr % mesh % indexToEdgeID % array(i) + do i = 1, nEdges + edgeIDSorted(1,i) = indexToEdgeID(i) edgeIDSorted(2,i) = i end do - call mpas_quicksort(block_ptr % mesh % nEdges, edgeIDSorted) + call mpas_quicksort(nEdges, edgeIDSorted) - do i=1,block_ptr % mesh % nVertices - vertexIDSorted(1,i) = block_ptr % mesh % indexToVertexID % array(i) + do i = 1, nVertices + vertexIDSorted(1,i) = indexToVertexID(i) vertexIDSorted(2,i) = i end do - call mpas_quicksort(block_ptr % mesh % nVertices, vertexIDSorted) + call mpas_quicksort(nVertices, vertexIDSorted) - do i=1,block_ptr % mesh % nCells - do j=1,block_ptr % mesh % nEdgesOnCell % array(i) - k = mpas_binary_search(cellIDSorted, 2, 1, block_ptr % mesh % nCells, & - block_ptr % mesh % cellsOnCell % array(j,i)) - if (k <= block_ptr % mesh % nCells) then - block_ptr % mesh % cellsOnCell % array(j,i) = cellIDSorted(2,k) + do i = 1, nCells + do j = 1, nEdgesOnCell(i) + k = mpas_binary_search(cellIDSorted, 2, 1, nCells, cellsOnCell(j,i)) + if (k <= nCells) then + cellsOnCell(j,i) = cellIDSorted(2,k) else - block_ptr % mesh % cellsOnCell % array(j,i) = block_ptr % mesh % nCells + 1 + cellsOnCell(j,i) = nCells + 1 end if - k = mpas_binary_search(edgeIDSorted, 2, 1, block_ptr % mesh % nEdges, & - block_ptr % mesh % edgesOnCell % array(j,i)) - if (k <= block_ptr % mesh % nEdges) then - block_ptr % mesh % edgesOnCell % array(j,i) = edgeIDSorted(2,k) + k = mpas_binary_search(edgeIDSorted, 2, 1, nEdges, edgesOnCell(j,i)) + if (k <= nEdges) then + edgesOnCell(j,i) = edgeIDSorted(2,k) else - block_ptr % mesh % edgesOnCell % array(j,i) = block_ptr % mesh % nEdges + 1 + edgesOnCell(j,i) = nEdges + 1 end if - k = mpas_binary_search(vertexIDSorted, 2, 1, block_ptr % mesh % nVertices, & - block_ptr % mesh % verticesOnCell % array(j,i)) - if (k <= block_ptr % mesh % nVertices) then - block_ptr % mesh % verticesOnCell % array(j,i) = vertexIDSorted(2,k) + k = mpas_binary_search(vertexIDSorted, 2, 1, nVertices, verticesOnCell(j,i)) + if (k <= nVertices) then + verticesOnCell(j,i) = vertexIDSorted(2,k) else - block_ptr % mesh % verticesOnCell % array(j,i) = block_ptr % mesh % nVertices + 1 + verticesOnCell(j,i) = nVertices + 1 end if end do end do - do i=1,block_ptr % mesh % nEdges - do j=1,2 + do i = 1, nEdges + do j = 1, 2 - k = mpas_binary_search(cellIDSorted, 2, 1, block_ptr % mesh % nCells, & - block_ptr % mesh % cellsOnEdge % array(j,i)) - if (k <= block_ptr % mesh % nCells) then - block_ptr % mesh % cellsOnEdge % array(j,i) = cellIDSorted(2,k) + k = mpas_binary_search(cellIDSorted, 2, 1, nCells, cellsOnEdge(j,i)) + if (k <= nCells) then + cellsOnEdge(j,i) = cellIDSorted(2,k) else - block_ptr % mesh % cellsOnEdge % array(j,i) = block_ptr % mesh % nCells + 1 + cellsOnEdge(j,i) = nCells + 1 end if - k = mpas_binary_search(vertexIDSorted, 2, 1, block_ptr % mesh % nVertices, & - block_ptr % mesh % verticesOnEdge % array(j,i)) - if (k <= block_ptr % mesh % nVertices) then - block_ptr % mesh % verticesOnEdge % array(j,i) = vertexIDSorted(2,k) + k = mpas_binary_search(vertexIDSorted, 2, 1, nVertices, verticesOnEdge(j,i)) + if (k <= nVertices) then + verticesOnEdge(j,i) = vertexIDSorted(2,k) else - block_ptr % mesh % verticesOnEdge % array(j,i) = block_ptr % mesh % nVertices + 1 + verticesOnEdge(j,i) = nVertices + 1 end if end do - do j=1,block_ptr % mesh % nEdgesOnEdge % array(i) + do j = 1, nEdgesOnEdge(i) - k = mpas_binary_search(edgeIDSorted, 2, 1, block_ptr % mesh % nEdges, & - block_ptr % mesh % edgesOnEdge % array(j,i)) - if (k <= block_ptr % mesh % nEdges) then - block_ptr % mesh % edgesOnEdge % array(j,i) = edgeIDSorted(2,k) + k = mpas_binary_search(edgeIDSorted, 2, 1, nEdges, edgesOnEdge(j,i)) + if (k <= nEdges) then + edgesOnEdge(j,i) = edgeIDSorted(2,k) else - block_ptr % mesh % edgesOnEdge % array(j,i) = block_ptr % mesh % nEdges + 1 + edgesOnEdge(j,i) = nEdges + 1 end if end do end do - do i=1,block_ptr % mesh % nVertices - do j=1,block_ptr % mesh % vertexDegree + do i = 1, nVertices + do j = 1, vertexDegree - k = mpas_binary_search(cellIDSorted, 2, 1, block_ptr % mesh % nCells, & - block_ptr % mesh % cellsOnVertex % array(j,i)) - if (k <= block_ptr % mesh % nCells) then - block_ptr % mesh % cellsOnVertex % array(j,i) = cellIDSorted(2,k) + k = mpas_binary_search(cellIDSorted, 2, 1, nCells, cellsOnVertex(j,i)) + if (k <= nCells) then + cellsOnVertex(j,i) = cellIDSorted(2,k) else - block_ptr % mesh % cellsOnVertex % array(j,i) = block_ptr % mesh % nCells + 1 + cellsOnVertex(j,i) = nCells + 1 end if - k = mpas_binary_search(edgeIDSorted, 2, 1, block_ptr % mesh % nEdges, & - block_ptr % mesh % edgesOnVertex % array(j,i)) - if (k <= block_ptr % mesh % nEdges) then - block_ptr % mesh % edgesOnVertex % array(j,i) = edgeIDSorted(2,k) + k = mpas_binary_search(edgeIDSorted, 2, 1, nEdges, edgesOnVertex(j,i)) + if (k <= nEdges) then + edgesOnVertex(j,i) = edgeIDSorted(2,k) else - block_ptr % mesh % edgesOnVertex % array(j,i) = block_ptr % mesh % nEdges + 1 + edgesOnVertex(j,i) = nEdges + 1 end if end do end do diff --git a/src/framework/mpas_block_decomp.F b/src/framework/mpas_block_decomp.F index 57bc6d7c3a..ade1e54dcd 100644 --- a/src/framework/mpas_block_decomp.F +++ b/src/framework/mpas_block_decomp.F @@ -54,7 +54,7 @@ module mpas_block_decomp !> This routine determines a list of cells for each processor, and what blocks the live in. ! !----------------------------------------------------------------------- - subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list, block_id, block_start, block_count)!{{{ + subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list, block_id, block_start, block_count, numBlocks, explicitProcDecomp, blockFilePrefix, procFilePrefix)!{{{ use mpas_configure @@ -67,6 +67,11 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l integer, dimension(:), pointer :: block_start !< Output: offset in local_cell_list for this blocks list of cells integer, dimension(:), pointer :: block_count !< Output: number of cells in blocks + integer, intent(in) :: numBlocks !< Input: Number of blocks (from config_num_blocks) + logical, intent(in) :: explicitProcDecomp !< Input: Logical flag controlling if blocks are explicitly assigned to processors + character (len=*), intent(in) :: blockFilePrefix, & !< Input: File prefix for block decomposition + procFilePrefix !< Input: File prefix for processor decomposition + integer, dimension(:), pointer :: global_block_list integer, dimension(:), pointer :: global_cell_list integer, dimension(:), pointer :: global_start @@ -83,15 +88,15 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l no_blocks = .false. - if(config_number_of_blocks == 0) then + if (numBlocks == 0) then total_blocks = dminfo % nProcs else - total_blocks = config_number_of_blocks + total_blocks = numBlocks end if - explicitDecomp = config_explicit_proc_decomp + explicitDecomp = explicitProcDecomp - call mpas_build_block_proc_list(dminfo) + call mpas_build_block_proc_list(dminfo, procFilePrefix) call mpas_get_blocks_per_proc(dminfo, dminfo % my_proc_id, blocks_per_proc) if(total_blocks > 1) then @@ -104,15 +109,15 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l iunit = 50 + dminfo % my_proc_id if (total_blocks < 10) then - write(filename,'(a,i1)') trim(config_block_decomp_file_prefix), total_blocks + write(filename,'(a,i1)') trim(blockFilePrefix), total_blocks else if (total_blocks < 100) then - write(filename,'(a,i2)') trim(config_block_decomp_file_prefix), total_blocks + write(filename,'(a,i2)') trim(blockFilePrefix), total_blocks else if (total_blocks < 1000) then - write(filename,'(a,i3)') trim(config_block_decomp_file_prefix), total_blocks + write(filename,'(a,i3)') trim(blockFilePrefix), total_blocks else if (total_blocks < 10000) then - write(filename,'(a,i4)') trim(config_block_decomp_file_prefix), total_blocks + write(filename,'(a,i4)') trim(blockFilePrefix), total_blocks else if (total_blocks < 100000) then - write(filename,'(a,i5)') trim(config_block_decomp_file_prefix), total_blocks + write(filename,'(a,i5)') trim(blockFilePrefix), total_blocks end if open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus) @@ -188,7 +193,7 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l allocate(block_start(blocks_per_proc)) allocate(block_count(blocks_per_proc)) - block_id(1) = config_number_of_blocks + 1 + block_id(1) = numBlocks + 1 block_start(1) = 0 block_count(1) = 0 else @@ -249,7 +254,7 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l allocate(block_start(1)) allocate(block_count(1)) local_cell_list(1) = 0 - block_id(1) = config_number_of_blocks + 1 + block_id(1) = numBlocks + 1 block_start(1) = 0 block_count(1) = 0 end if @@ -611,13 +616,14 @@ end subroutine mpas_get_owning_proc!}}} !> This routine builds the mapping of blocks to processors. Most useful when using an explicit decomposition. ! !----------------------------------------------------------------------- - subroutine mpas_build_block_proc_list(dminfo)!{{{ + subroutine mpas_build_block_proc_list(dminfo, procFilePrefix)!{{{ use mpas_configure implicit none type(dm_info), intent(in) :: dminfo !< Input: Domain information + character (len=*), intent(in) :: procFilePrefix integer :: iounit, istatus, i, owning_proc character (len=StrKIND) :: filename @@ -635,15 +641,15 @@ subroutine mpas_build_block_proc_list(dminfo)!{{{ iounit = 51 + dminfo % my_proc_id if (dminfo % nProcs < 10) then - write(filename,'(a,i1)') trim(config_proc_decomp_file_prefix), dminfo % nProcs + write(filename,'(a,i1)') trim(procFilePrefix), dminfo % nProcs else if (dminfo % nProcs < 100) then - write(filename,'(a,i2)') trim(config_proc_decomp_file_prefix), dminfo % nProcs + write(filename,'(a,i2)') trim(procFilePrefix), dminfo % nProcs else if (dminfo % nProcs < 1000) then - write(filename,'(a,i3)') trim(config_proc_decomp_file_prefix), dminfo % nProcs + write(filename,'(a,i3)') trim(procFilePrefix), dminfo % nProcs else if (dminfo % nProcs < 10000) then - write(filename,'(a,i4)') trim(config_proc_decomp_file_prefix), dminfo % nProcs + write(filename,'(a,i4)') trim(procFilePrefix), dminfo % nProcs else if (dminfo % nProcs < 100000) then - write(filename,'(a,i5)') trim(config_proc_decomp_file_prefix), dminfo % nProcs + write(filename,'(a,i5)') trim(procFilePrefix), dminfo % nProcs end if open(unit=iounit, file=trim(filename), form='formatted', status='old', iostat=istatus) diff --git a/src/framework/mpas_io_input.F b/src/framework/mpas_bootstrapping.F similarity index 61% rename from src/framework/mpas_io_input.F rename to src/framework/mpas_bootstrapping.F index 23a1bd0ffb..a5a9e5934b 100644 --- a/src/framework/mpas_io_input.F +++ b/src/framework/mpas_bootstrapping.F @@ -5,7 +5,7 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! -module mpas_io_input +module mpas_bootstrapping use mpas_grid_types use mpas_dmpar @@ -17,44 +17,73 @@ module mpas_io_input use mpas_io_streams use mpas_io_units - integer, parameter :: STREAM_INPUT=1, STREAM_SFC=2, STREAM_RESTART=3 - - type io_input_object - character (len=StrKIND) :: filename - integer :: rd_ncid - integer :: stream - - integer :: time - - type (MPAS_Stream_type) :: io_stream - - end type io_input_object integer :: readCellStart, readCellEnd, nReadCells integer :: readEdgeStart, readEdgeEnd, nReadEdges integer :: readVertexStart, readVertexEnd, nReadVertices + contains - subroutine mpas_input_state_for_domain(domain)!{{{ + + !*********************************************************************** + ! + ! routine mpas_bootstrap_framework + ! + !> \brief Obtains mesh partition, builds halos, and allocates blocks. + !> \author Michael Duda + !> \date 7 September 2014 + !> \details + !> This routine is responsible for reading basic decomposed field dimensions, + !> determining a block decomposition of the mesh, building halos for fields, + !> and, finally, allocating blocklist for a domain. + !> + !> Dimensions required to be present in the grid file: + !> nCells + !> nEdges + !> nVertices + !> vertexDegree + !> maxEdges + !> ***** and, at present, all other dimensions so we can allocate all fields + !> + !> Fields required to be present in the grid file: + !> indexToCellID + !> indexToEdgeID + !> indexToVertexID + !> {x,y,z}Cell + !> {x,y,z}Edge + !> {x,y,z}Vertex + !> nEdgesOnCell + !> cellsOnCell + !> edgesOnCell + !> verticesOnCell + !> cellsOnEdge + !> cellsOnVertex + !> + !> Attributes required to be present in the grid file: + !> on_a_sphere + !> sphere_radius + !> ***** these are needed by mpas_block_creator_finalize_block_init() + !> so they can be set in the mesh pool and queried by, e.g., + !> mpas_initialize_vectors() + ! + !----------------------------------------------------------------------- + subroutine mpas_bootstrap_framework(domain, mesh_filename) !{{{ implicit none type (domain_type), pointer :: domain + character(len=*), intent(in) :: mesh_filename - type (block_type), pointer :: block_ptr type (block_type), pointer :: readingBlock - integer :: i, j, k - type (io_input_object) :: input_obj -#include "dim_decls.inc" - - character (len=StrKIND) :: c_on_a_sphere - real (kind=RKIND) :: r_sphere_radius +#include "dim_dummy_defines_noinput.inc" integer :: ierr - integer, dimension(:), pointer :: readIndices type (MPAS_IO_Handle_type) :: inputHandle + + character (len=StrKIND) :: c_on_a_sphere + real (kind=RKIND) :: r_sphere_radius type (field1dInteger), pointer :: indexToCellIDField type (field1dInteger), pointer :: indexToEdgeIDField @@ -70,8 +99,6 @@ subroutine mpas_input_state_for_domain(domain)!{{{ type (field1dReal), pointer :: xEdgeField, yEdgeField, zEdgeField type (field1dReal), pointer :: xVertexField, yVertexField, zVertexField - type (field1DChar) :: xtime - type (field1dInteger), pointer :: nCellsSolveField type (field1dInteger), pointer :: nVerticesSolveField type (field1dInteger), pointer :: nEdgesSolveField @@ -88,10 +115,6 @@ subroutine mpas_input_state_for_domain(domain)!{{{ type (field1DInteger), pointer :: indexToEdgeID_Block type (field2DInteger), pointer :: cellsOnEdge_Block - type (field1DReal), pointer :: xCell, yCell, zCell - type (field1DReal), pointer :: xEdge, yEdge, zEdge - type (field1DReal), pointer :: xVertex, yVertex, zVertex - integer, dimension(:), pointer :: local_cell_list integer, dimension(:), pointer :: block_id, block_start, block_count type (graph) :: partial_global_graph_info @@ -100,50 +123,37 @@ subroutine mpas_input_state_for_domain(domain)!{{{ character(len=StrKIND) :: timeStamp, restartTimeStamp character(len=StrKIND) :: filename + integer, pointer :: config_num_halos, config_number_of_blocks + logical, pointer :: config_explicit_proc_decomp + character (len=StrKIND), pointer :: config_block_decomp_file_prefix, config_proc_decomp_file_prefix integer :: nHalos - nHalos = config_num_halos - if (config_do_restart) then - ! this get followed by set is to ensure that the time is in standard format - if(trim(config_start_time) == 'file') then - open(22,file=trim(config_restart_timestamp_name),form='formatted',status='old') - read(22,*) restartTimeStamp - close(22) + call mpas_pool_get_config(domain % configs, 'config_num_halos', config_num_halos) + call mpas_pool_get_config(domain % configs, 'config_number_of_blocks', config_number_of_blocks) + call mpas_pool_get_config(domain % configs, 'config_explicit_proc_decomp', config_explicit_proc_decomp) + call mpas_pool_get_config(domain % configs, 'config_block_decomp_file_prefix', config_block_decomp_file_prefix) + call mpas_pool_get_config(domain % configs, 'config_proc_decomp_file_prefix', config_proc_decomp_file_prefix) - else - restartTimeStamp = config_start_time - end if + nHalos = config_num_halos - write(stderrUnit,*) '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) - input_obj % stream = STREAM_RESTART - else - input_obj % filename = trim(config_input_name) - input_obj % stream = STREAM_INPUT - end if - inputHandle = MPAS_io_open(trim(input_obj % filename), MPAS_IO_READ, MPAS_IO_PNETCDF, ierr) + inputHandle = MPAS_io_open(trim(mesh_filename), MPAS_IO_READ, MPAS_IO_PNETCDF, ierr=ierr) if (ierr /= MPAS_IO_NOERR) then - write(stderrUnit,*) ' ' - if (input_obj % stream == STREAM_RESTART) then - write(stderrUnit,*) 'Error opening restart file ''', trim(input_obj % filename), '''' - else if (input_obj % stream == STREAM_INPUT) then - write(stderrUnit,*) 'Error opening input file ''', trim(input_obj % filename), '''' - else if (input_obj % stream == STREAM_SFC) then - write(stderrUnit,*) 'Error opening sfc file ''', trim(input_obj % filename), '''' - end if - write(stderrUnit,*) ' ' - call mpas_dmpar_abort(domain % dminfo) + write(stderrUnit,*) ' ' + write(stderrUnit,*) '************************************************************************************' + write(stderrUnit,*) 'Error: Could not open input file '''//trim(mesh_filename)//''' to read mesh fields' + write(stderrUnit,*) '************************************************************************************' + call mpas_dmpar_abort(domain % dminfo) end if + ! ! Read global number of cells/edges/vertices ! -#include "read_dims.inc" +!MGD for bootstrapping, we really only need a small, fixed set of dimensions +! HOWEVER: in order to allocate all fields, we need all non-derived dimensions... +#include "read_dimensions.inc" ! ! Determine the range of cells/edges/vertices that a processor will initially read @@ -168,13 +178,16 @@ subroutine mpas_input_state_for_domain(domain)!{{{ ! which cells/edges/vertices are owned by each block, and which are ghost ! - call mpas_io_setup_cell_block_fields(inputHandle, nreadCells, readCellStart, readingBlock, maxEdges, indexTocellIDField, xCellField, & - yCellField, zCellField, nEdgesOnCellField, cellsOnCellField, edgesOnCellField, verticesOnCellField) + call mpas_io_setup_cell_block_fields(inputHandle, nreadCells, readCellStart, readingBlock, maxEdges, & + indexTocellIDField, xCellField, yCellField, zCellField, nEdgesOnCellField, & + cellsOnCellField, edgesOnCellField, verticesOnCellField, nHalos) - call mpas_io_setup_edge_block_fields(inputHandle, nReadEdges, readEdgeStart, readingBlock, indexToEdgeIDField, xEdgeField, yEdgeField, zEdgeField, cellsOnEdgeField) + call mpas_io_setup_edge_block_fields(inputHandle, nReadEdges, readEdgeStart, readingBlock, indexToEdgeIDField, & + xEdgeField, yEdgeField, zEdgeField, cellsOnEdgeField, nHalos) - call mpas_io_setup_vertex_block_fields(inputHandle, nReadVertices, readVertexStart, readingBlock, vertexDegree, indexToVertexIDField, & - xVertexField, yVertexField, zVertexField, cellsOnVertexField) + call mpas_io_setup_vertex_block_fields(inputHandle, nReadVertices, readVertexStart, readingBlock, vertexDegree, & + indexToVertexIDField, xVertexField, yVertexField, zVertexField, cellsOnVertexField, & + nHalos) ! ! Set up a graph derived data type describing the connectivity for the cells ! that were read by this process @@ -197,134 +210,78 @@ subroutine mpas_input_state_for_domain(domain)!{{{ ! TODO: Ensure (by renaming or exchanging) that initial cell range on each proc is contiguous ! This situation may occur when reading a restart file with cells/edges/vertices written ! in a scrambled order - + ! ! Determine which cells are owned by this process - call mpas_block_decomp_cells_for_proc(domain % dminfo, partial_global_graph_info, local_cell_list, block_id, block_start, block_count) + ! + call mpas_block_decomp_cells_for_proc(domain % dminfo, partial_global_graph_info, local_cell_list, block_id, block_start, & + block_count, config_number_of_blocks, config_explicit_proc_decomp, & + config_block_decomp_file_prefix, config_proc_decomp_file_prefix) deallocate(partial_global_graph_info % vertexID) deallocate(partial_global_graph_info % nAdjacent) deallocate(partial_global_graph_info % adjacencyList) - call mpas_block_creator_setup_blocks_and_0halo_cells(domain, indexToCellID_Block, local_cell_list, block_id, block_start, block_count) - call mpas_block_creator_build_0halo_cell_fields(indexToCellIDField, nEdgesOnCellField, cellsOnCellField, verticesOnCellField, edgesOnCellField, indexToCellID_Block, nEdgesOnCell_Block, cellsOnCell_Block, verticesOnCell_Block, edgesOnCell_Block) + call mpas_block_creator_setup_blocks_and_0halo_cells(nHalos, domain, indexToCellID_Block, local_cell_list, block_id, & + block_start, block_count) + call mpas_block_creator_build_0halo_cell_fields(nHalos, indexToCellIDField, nEdgesOnCellField, cellsOnCellField, & + verticesOnCellField, edgesOnCellField, indexToCellID_Block, & + nEdgesOnCell_Block, cellsOnCell_Block, verticesOnCell_Block, & + edgesOnCell_Block) + + call mpas_block_creator_build_0_and_1halo_edge_fields(nHalos, indexToEdgeIDField, cellsOnEdgeField, indexToCellID_Block, & + nEdgesOnCell_Block, edgesOnCell_Block, indexToEdgeID_Block, & + cellsOnEdge_Block, nEdgesSolveField) + call mpas_block_creator_build_0_and_1halo_edge_fields(nHalos, indexToVertexIDField, cellsOnVertexField, indexToCellID_Block, & + nEdgesOnCell_Block, verticesOnCell_Block, indexToVertexID_Block, & + cellsOnVertex_Block, nVerticesSolveField) + + call mpas_block_creator_build_cell_halos(nHalos, indexToCellID_Block, nEdgesOnCell_Block, cellsOnCell_Block, & + verticesOnCell_Block, edgesOnCell_Block, nCellsSolveField) + + call mpas_block_creator_build_edge_halos(nHalos, indexToCellID_Block, nEdgesOnCell_Block, nCellsSolveField, & + edgesOnCell_Block, indexToEdgeID_Block, cellsOnEdge_Block, nEdgesSolveField) + call mpas_block_creator_build_edge_halos(nHalos, indexToCellID_Block, nEdgesOnCell_Block, nCellsSolveField, & + verticesOnCell_Block, indexToVertexID_Block, cellsOnVertex_Block, & + nVerticesSolveField) - call mpas_block_creator_build_0_and_1halo_edge_fields(indexToEdgeIDField, cellsOnEdgeField, indexToCellID_Block, nEdgesOnCell_Block, edgesOnCell_Block, indexToEdgeID_Block, cellsOnEdge_Block, nEdgesSolveField) - call mpas_block_creator_build_0_and_1halo_edge_fields(indexToVertexIDField, cellsOnVertexField, indexToCellID_Block, nEdgesOnCell_Block, verticesOnCell_Block, indexToVertexID_Block, cellsOnVertex_Block, nVerticesSolveField) - - call mpas_block_creator_build_cell_halos(indexToCellID_Block, nEdgesOnCell_Block, cellsOnCell_Block, verticesOnCell_Block, edgesOnCell_Block, nCellsSolveField) - - call mpas_block_creator_build_edge_halos(indexToCellID_Block, nEdgesOnCell_Block, nCellsSolveField, edgesOnCell_Block, indexToEdgeID_Block, cellsOnEdge_Block, nEdgesSolveField) - call mpas_block_creator_build_edge_halos(indexToCellID_Block, nEdgesOnCell_Block, nCellsSolveField, verticesOnCell_Block, indexToVertexID_Block, cellsOnVertex_Block, nVerticesSolveField) - - - ! Allocate blocks, and copy indexTo arrays into blocks - call mpas_block_creator_finalize_block_init(domain % blocklist, & -#include "dim_dummy_args.inc" - , nCellsSolveField, nEdgesSolveField, nVerticesSolveField, indexToCellID_Block, indexToEdgeID_Block, indexToVertexID_Block) - - - call mpas_io_input_init(input_obj, domain % blocklist, domain % dminfo) - - call MPAS_readStreamAtt(input_obj % io_stream, 'sphere_radius', r_sphere_radius, ierr) - if (ierr /= MPAS_STREAM_NOERR) then - write(stderrUnit,*) 'Warning: Attribute sphere_radius not found in '//trim(input_obj % filename) - write(stderrUnit,*) ' Setting sphere_radius to 1.0' - domain % blocklist % mesh % sphere_radius = 1.0 - else - domain % blocklist % mesh % sphere_radius = r_sphere_radius - end if - - call MPAS_readStreamAtt(input_obj % io_stream, 'on_a_sphere', c_on_a_sphere, ierr) - if (ierr /= MPAS_STREAM_NOERR) then - write(stderrUnit,*) 'Warning: Attribute on_a_sphere not found in '//trim(input_obj % filename) - write(stderrUnit,*) ' Setting on_a_sphere to ''YES''' - domain % blocklist % mesh % on_a_sphere = .true. + ! + ! Before we can allocate blocks, we need the attributes on_a_sphere and sphere_radius so + ! they can be propagated as configs to subpools + ! + call MPAS_io_get_att(inputHandle, 'on_a_sphere', c_on_a_sphere, ierr=ierr) + if (ierr /= MPAS_IO_NOERR) then + write(stderrUnit,*) 'Warning: Attribute on_a_sphere not found in '//trim(mesh_filename) + write(stderrUnit,*) ' Setting on_a_sphere to ''YES''' + domain % on_a_sphere = .true. else - if (index(c_on_a_sphere, 'YES') /= 0) then - domain % blocklist % mesh % on_a_sphere = .true. - else - domain % blocklist % mesh % on_a_sphere = .false. - end if + if (index(c_on_a_sphere, 'YES') /= 0) then + domain % on_a_sphere = .true. + else + domain % on_a_sphere = .false. + end if end if -#ifndef MPAS_CESM - call MPAS_readStreamAtt(input_obj % io_stream, 'history', domain % history, ierr) - if (ierr /= MPAS_STREAM_NOERR) then - write(stderrUnit,*) 'Warning: Attribute History not found in '//trim(input_obj % filename) - write(stderrUnit,*) ' Setting History to ''''' - domain % history = "" + call MPAS_io_get_att(inputHandle, 'sphere_radius', r_sphere_radius, ierr=ierr) + if (ierr /= MPAS_IO_NOERR) then + write(stderrUnit,*) 'Warning: Attribute sphere_radius not found in '//trim(mesh_filename) + write(stderrUnit,*) ' Setting sphere_radius to 1.0' + domain % sphere_radius = 1.0 else - ! Remove C String NULL characters, replace C String newlines with semicolons - do i = 1, len(domain % history) - if(iachar(domain % history(i:i)) == 0) then - domain % history(i:i) = " " - else if(iachar(domain % history(i:i)) == 10) then - domain % history(i:i) = ";" - end if - end do + domain % sphere_radius = r_sphere_radius end if -#else - domain % history = "cesm_run" -#endif - - block_ptr => domain % blocklist % next - 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 - ! Link the sendList and recvList pointers in each field type to the appropriate lists - ! in parinfo, e.g., cellsToSend and cellsToRecv; in future, it can also be extended to - ! link blocks of fields to eachother - call mpas_create_field_links(block_ptr) - block_ptr => block_ptr % next - end do - - if (.not. config_do_restart) then - input_obj % time = 1 - else - ! - ! 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, restartTimeStamp, MPAS_STREAM_EXACT_TIME, timeStamp, ierr) - if (ierr == MPAS_IO_ERR) then - write(stderrUnit,*) '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(stderrUnit,*) 'Error: restart file '//trim(filename)//' did not contain time '//trim(config_start_time) -! call mpas_dmpar_abort(domain % dminfo) -! end if -!write(stderrUnit,*) 'MGD DEBUGGING time = ', input_obj % time - write(stderrUnit,*) 'Restarting model from time ', trim(timeStamp) - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Do the actual work of reading all fields in from the input or restart file - ! For each field: - ! 1) Each process reads a contiguous range of cell/edge/vertex indices, which - ! may not correspond with the cells/edges/vertices that are owned by the - ! 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}List - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call mpas_read_and_distribute_fields(input_obj) + ! Allocate blocks, and copy indexTo arrays into blocks + call mpas_block_creator_finalize_block_init(nHalos, domain % blocklist, & +#include "dim_dummy_args.inc" + , nCellsSolveField, nEdgesSolveField, nVerticesSolveField, indexToCellID_Block, indexToEdgeID_Block, & + indexToVertexID_Block) - call mpas_io_input_finalize(input_obj, domain % dminfo) + call mpas_link_fields(domain) call MPAS_io_close(inputHandle, ierr) - ! - ! Exchange halos for all of the fields that were read from the input file - ! - call mpas_exch_input_field_halos(domain, input_obj) - - call mpas_block_creator_reindex_block_fields(domain % blocklist) call mpas_dmpar_destroy_mulithalo_exchange_list(indexToCellIDField % sendList) call mpas_dmpar_destroy_mulithalo_exchange_list(indexToCellIDField % recvList) @@ -368,103 +325,14 @@ subroutine mpas_input_state_for_domain(domain)!{{{ deallocate(block_count) deallocate(readingBlock) - end subroutine mpas_input_state_for_domain!}}} - - !CR:TODO: an identical subroutine is found in module_io_output - merge - subroutine mpas_insert_string_suffix(stream, suffix, filename)!{{{ - - implicit none - - character (len=*), intent(in) :: stream - character (len=*), intent(in) :: suffix - character (len=*), intent(out) :: filename - integer :: length, i - - filename = trim(stream) // '.' // trim(suffix) + end subroutine mpas_bootstrap_framework !}}} - length = len_trim(stream) - do i=length-1,1,-1 - if(stream(i:i) == '.') then - filename = trim(stream(:i)) // trim(suffix) // trim(stream(i:)) - exit - end if - end do - - do i=1,len_trim(filename) - if (filename(i:i) == ':') filename(i:i) = '.' - end do - end subroutine mpas_insert_string_suffix!}}} + subroutine mpas_io_setup_cell_block_fields(inputHandle, nReadCells, readCellStart, readingBlock, maxEdges, indexToCellID, & + xCell, yCell, zCell, nEdgesOnCell, cellsOnCell, edgesOnCell, verticesOnCell, nHalos) !{{{ - subroutine mpas_read_and_distribute_fields(input_obj)!{{{ - - implicit none + implicit none - type (io_input_object), intent(inout) :: input_obj - - integer :: ierr - - - call MPAS_readStream(input_obj % io_stream, input_obj % time, ierr) - - - end subroutine mpas_read_and_distribute_fields!}}} - - subroutine mpas_io_input_init(input_obj, blocklist, dminfo)!{{{ - - implicit none - - type (io_input_object), intent(inout) :: input_obj - type (block_type), intent(in) :: blocklist - type (dm_info), intent(in) :: dminfo - - integer :: nferr - - call MPAS_createStream(input_obj % io_stream, trim(input_obj % filename), MPAS_IO_PNETCDF, MPAS_IO_READ, 1, nferr) - if (nferr /= MPAS_STREAM_NOERR) then - write(stderrUnit,*) ' ' - if (input_obj % stream == STREAM_RESTART) then - write(stderrUnit,*) 'Error opening restart file ''', trim(input_obj % filename), '''' - else if (input_obj % stream == STREAM_INPUT) then - write(stderrUnit,*) 'Error opening input file ''', trim(input_obj % filename), '''' - else if (input_obj % stream == STREAM_SFC) then - write(stderrUnit,*) 'Error opening sfc file ''', trim(input_obj % filename), '''' - end if - write(stderrUnit,*) ' ' - call mpas_dmpar_abort(dminfo) - end if - -#include "add_input_fields.inc" - - end subroutine mpas_io_input_init!}}} - - subroutine mpas_exch_input_field_halos(domain, input_obj)!{{{ - - implicit none - - type (domain_type), intent(inout) :: domain - type (io_input_object), intent(inout) :: input_obj - -#include "exchange_input_field_halos.inc" - -#include "non_decomp_copy_input_fields.inc" - - end subroutine mpas_exch_input_field_halos!}}} - - subroutine mpas_io_input_finalize(input_obj, dminfo)!{{{ - - implicit none - - type (io_input_object), intent(inout) :: input_obj - type (dm_info), intent(in) :: dminfo - - integer :: nferr - - call MPAS_closeStream(input_obj % io_stream, nferr) - - end subroutine mpas_io_input_finalize!}}} - - subroutine mpas_io_setup_cell_block_fields(inputHandle, nReadCells, readCellStart, readingBlock, maxEdges, indexToCellID, xCell, yCell, zCell, nEdgesOnCell, cellsOnCell, edgesOnCell, verticesOnCell)!{{{ type (MPAS_IO_Handle_type) :: inputHandle integer, intent(in) :: nReadCells integer, intent(in) :: readCellStart @@ -478,12 +346,11 @@ subroutine mpas_io_setup_cell_block_fields(inputHandle, nReadCells, readCellStar type (field2dInteger), pointer :: cellsOnCell type (field2dInteger), pointer :: edgesOnCell type (field2dInteger), pointer :: verticesOnCell + integer, intent(in) :: nHalos - integer :: i, nHalos + integer :: i, ierr integer, dimension(:), pointer :: readIndices - nHalos = config_num_halos - ! ! Allocate and read fields that we will need in order to ultimately work out ! which cells/edges/vertices are owned by each block, and which are ghost @@ -590,9 +457,14 @@ subroutine mpas_io_setup_cell_block_fields(inputHandle, nReadCells, readCellStar deallocate(readIndices) - end subroutine mpas_io_setup_cell_block_fields!}}} + end subroutine mpas_io_setup_cell_block_fields !}}} + + + subroutine mpas_io_setup_edge_block_fields(inputHandle, nReadEdges, readEdgeStart, readingBlock, indexToEdgeID, & + xEdge, yEdge, zEdge, cellsOnEdge, nHalos) !{{{ + + implicit none - subroutine mpas_io_setup_edge_block_fields(inputHandle, nReadEdges, readEdgeStart, readingBlock, indexToEdgeID, xEdge, yEdge, zEdge, cellsOnEdge)!{{{ type (MPAS_IO_Handle_type) :: inputHandle integer, intent(in) :: nReadEdges integer, intent(in) :: readEdgeStart @@ -602,12 +474,11 @@ subroutine mpas_io_setup_edge_block_fields(inputHandle, nReadEdges, readEdgeStar type (field1dReal), pointer :: yEdge type (field1dReal), pointer :: zEdge type (field2dInteger), pointer :: cellsOnEdge + integer, intent(in) :: nHalos - integer :: i, nHalos + integer :: i, ierr integer, dimension(:), pointer :: readIndices - nHalos = config_num_halos - ! ! Allocate and read fields that we will need in order to ultimately work out ! which cells/edges/vertices are owned by each block, and which are ghost @@ -661,9 +532,14 @@ subroutine mpas_io_setup_edge_block_fields(inputHandle, nReadEdges, readEdgeStar deallocate(readIndices) - end subroutine mpas_io_setup_edge_block_fields!}}} + end subroutine mpas_io_setup_edge_block_fields !}}} + + + subroutine mpas_io_setup_vertex_block_fields(inputHandle, nReadVertices, readVertexStart, readingBlock, vertexDegree, & + indexToVertexID, xVertex, yVertex, zVertex, cellsOnVertex, nHalos) !{{{ + + implicit none - subroutine mpas_io_setup_vertex_block_fields(inputHandle, nReadVertices, readVertexStart, readingBlock, vertexDegree, indexToVertexID, xVertex, yVertex, zVertex, cellsOnVertex)!{{{ type (MPAS_IO_Handle_type) :: inputHandle integer, intent(in) :: nReadVertices integer, intent(in) :: readVertexStart @@ -674,12 +550,11 @@ subroutine mpas_io_setup_vertex_block_fields(inputHandle, nReadVertices, readVer type (field1dReal), pointer :: yVertex type (field1dReal), pointer :: zVertex type (field2dInteger), pointer :: cellsOnVertex + integer, intent(in) :: nHalos - integer :: i, nHalos + integer :: i, ierr integer, dimension(:), pointer :: readIndices - nHalos = config_num_halos - ! Global vertex indices allocate(indexToVertexID) allocate(indexToVertexID % ioinfo) @@ -726,7 +601,8 @@ subroutine mpas_io_setup_vertex_block_fields(inputHandle, nReadVertices, readVer deallocate(readIndices) - end subroutine mpas_io_setup_vertex_block_fields!}}} + end subroutine mpas_io_setup_vertex_block_fields !}}} + +#include "setup_immutable_streams.inc" - -end module mpas_io_input +end module mpas_bootstrapping diff --git a/src/framework/mpas_c_interfacing.F b/src/framework/mpas_c_interfacing.F new file mode 100644 index 0000000000..dd885600f4 --- /dev/null +++ b/src/framework/mpas_c_interfacing.F @@ -0,0 +1,74 @@ +module mpas_c_interfacing + + + contains + + + !----------------------------------------------------------------------- + ! routine mpas_c_to_f_string + ! + !> \brief Converts a C null-terminated string to a Fortran string + !> \author Michael Duda + !> \date 9 July 2014 + !> \details + !> Converts a C null-terminated string to a Fortran string. + ! + !----------------------------------------------------------------------- + subroutine mpas_c_to_f_string(cstring, fstring) + + + use iso_c_binding, only : c_char, c_null_char + + implicit none + + character(kind=c_char), dimension(*), intent(in) :: cstring + character(len=*), intent(out) :: fstring + + integer :: i, j + + j = len(fstring) + do i=1,j + if (cstring(i) == c_null_char) exit + end do + if (i > j) then + i = j + else + i = i - 1 + end if + fstring(1:i) = transfer(cstring(1:i), fstring) + fstring = fstring(1:i) + + end subroutine mpas_c_to_f_string + + + !----------------------------------------------------------------------- + ! routine mpas_f_to_c_string + ! + !> \brief Converts a Fortran string to a C null-terminated string + !> \author Michael Duda + !> \date 9 July 2014 + !> \details + !> Converts a Fortran string to a C null-terminated string. + !> The output argument is an assumed-size array that must be large enough + !> to contain the Fortran string, plus a c_null_char character. + ! + !----------------------------------------------------------------------- + subroutine mpas_f_to_c_string(fstring, cstring) + + use iso_c_binding, only : c_char, c_null_char + + implicit none + + character(len=*), intent(in) :: fstring + character(kind=c_char), dimension(*), intent(out) :: cstring + + integer :: i + + do i=1,len_trim(fstring) + cstring(i) = fstring(i:i) + end do + cstring(i) = c_null_char + + end subroutine mpas_f_to_c_string + +end module mpas_c_interfacing diff --git a/src/framework/mpas_configure.F b/src/framework/mpas_configure.F index 25feb2ce83..d5b678e580 100644 --- a/src/framework/mpas_configure.F +++ b/src/framework/mpas_configure.F @@ -20,8 +20,6 @@ module mpas_configure use mpas_dmpar use mpas_io_units -#include "config_defs.inc" - contains !----------------------------------------------------------------------- @@ -34,38 +32,8 @@ module mpas_configure !> This routine reads and broadcasts the namelist file. ! !----------------------------------------------------------------------- - subroutine mpas_read_namelist(dminfo, nml_filename) - - implicit none - - type (dm_info), intent(in) :: dminfo !< Input: Domain information - character (len=*), optional :: nml_filename !< Input - Optional: Namelist filename. Defaults to namelist.input - - integer :: funit, ierr - -#include "config_namelist_defs.inc" - - funit = 21 - - ! Set default values for namelist options -#include "config_set_defaults.inc" - - if (dminfo % my_proc_id == IO_NODE) then - if (present(nml_filename)) then - write(stderrUnit,*) 'Reading ', trim(nml_filename) - open(funit,file=trim(nml_filename),status='old',form='formatted') - else - write(stderrUnit,*) 'Reading namelist.input' - open(funit,file='namelist.input',status='old',form='formatted') - end if - -#include "config_namelist_reads.inc" - close(funit) - write(stderrUnit,*) ' ' - end if - -#include "config_bcast_namelist.inc" - end subroutine mpas_read_namelist +#include "namelist_call.inc" +#include "namelist_defines.inc" end module mpas_configure diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index be0ead4da3..ecbf90b19c 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -205,34 +205,6 @@ subroutine mpas_dmpar_abort(dminfo)!{{{ end subroutine mpas_dmpar_abort!}}} -!----------------------------------------------------------------------- -! routine mpas_dmpar_global_abort -! -!> \brief MPAS dmpar global abort routine. -!> \author Michael Duda -!> \date 03/26/13 -!> \details -!> This routine aborts MPI. A call to it kills the model through the use of MPI_Abort on the world communicator, and outputs a message. -! -!----------------------------------------------------------------------- - subroutine mpas_dmpar_global_abort(mesg)!{{{ - - implicit none - - character (len=*), intent(in) :: mesg !< Input: Abort message - -#ifdef _MPI - integer :: mpi_ierr, mpi_errcode - - write(stderrUnit,*) trim(mesg) - call MPI_Abort(MPI_COMM_WORLD, mpi_errcode, mpi_ierr) -#endif - - write(stderrUnit,*) trim(mesg) - stop - - end subroutine mpas_dmpar_global_abort!}}} - !----------------------------------------------------------------------- ! routine mpas_dmpar_bcast_int ! @@ -1347,17 +1319,21 @@ subroutine mpas_dmpar_get_exch_list(haloLayer, ownedListField, neededListField, ! deallocate(numToSend) deallocate(numToRecv) - deallocate(ownedList) - deallocate(ownedListIndex) - deallocate(ownedBlock) deallocate(neededList) deallocate(neededListIndex) deallocate(neededBlock) + + deallocate(ownedList) + deallocate(ownedListIndex) + deallocate(ownedBlock) deallocate(ownedListSorted) deallocate(ownedBlockSorted) + deallocate(recipientList) + deallocate(ownerListIn) deallocate(ownerListOut) + deallocate(uniqueSortedNeededList) deallocate(packingOrder) #endif @@ -1443,6 +1419,7 @@ subroutine mpas_dmpar_get_exch_list(haloLayer, ownedListField, neededListField, end do deallocate(numToSend) deallocate(offSetList) + deallocate(ownedLimitList) end subroutine mpas_dmpar_get_exch_list!}}} @@ -5742,3 +5719,37 @@ subroutine mpas_dmpar_copy_field5d_real(field)!{{{ end subroutine mpas_dmpar_copy_field5d_real!}}} end module mpas_dmpar + +!----------------------------------------------------------------------- +! routine mpas_dmpar_global_abort +! +!> \brief MPAS dmpar global abort routine. +!> \author Michael Duda +!> \date 03/26/13 +!> \details +!> This routine aborts MPI. A call to it kills the model through the use of MPI_Abort on the world communicator, and outputs a message. +! +!----------------------------------------------------------------------- + subroutine mpas_dmpar_global_abort(mesg)!{{{ + + use mpas_io_units + + implicit none + + include 'mpif.h' + + character (len=*), intent(in) :: mesg !< Input: Abort message + +#ifdef _MPI + integer :: mpi_ierr, mpi_errcode + + write(stderrUnit,*) trim(mesg) + call MPI_Abort(MPI_COMM_WORLD, mpi_errcode, mpi_ierr) +#endif + + write(stderrUnit,*) trim(mesg) + stop + + end subroutine mpas_dmpar_global_abort!}}} + + diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 6d795563a8..d3705852ec 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -19,16 +19,16 @@ module mpas_framework use mpas_dmpar use mpas_grid_types - use mpas_io_input - use mpas_io_output use mpas_timer use mpas_timekeeping use mpas_io use mpas_io_units + use mpas_configure contains + !----------------------------------------------------------------------- ! routine mpas_framework_init ! @@ -36,7 +36,8 @@ module mpas_framework !> \author Michael Duda, Doug Jacobsen !> \date 03/26/13 !> \details -!> This routine initializes the MPAS framework. It calls routines related to initializing different parts of MPAS, that are housed within the framework. +!> This routine initializes the MPAS framework. It calls routines related +!> to initializing different parts of MPAS, that are housed within the framework. ! !----------------------------------------------------------------------- subroutine mpas_framework_init(dminfo, domain, mpi_comm, nml_filename, io_system, calendar, stdoutUnit, stderrUnit)!{{{ @@ -47,27 +48,44 @@ subroutine mpas_framework_init(dminfo, domain, mpi_comm, nml_filename, io_system type (domain_type), pointer :: domain integer, intent(in), optional :: mpi_comm - character (len=*), optional :: nml_filename + character(len=*), optional :: nml_filename type (iosystem_desc_t), optional, pointer :: io_system character(len=*), intent(in), optional :: calendar integer, intent(in), optional :: stdoutUnit, stderrUnit + character(len=StrKIND), pointer :: config_calendar_type + integer, pointer :: config_pio_num_iotasks, config_pio_stride integer :: pio_num_iotasks integer :: pio_stride + allocate(dminfo) call mpas_io_units_init(stdoutUnit, stderrUnit) call mpas_dmpar_init(dminfo, mpi_comm) - call mpas_read_namelist(dminfo, nml_filename) +#ifdef MPAS_DEBUG + call mpas_pool_set_error_level(MPAS_POOL_WARN) +#endif call mpas_allocate_domain(domain, dminfo) + + if (.not. present(nml_filename)) then + call mpas_setup_namelists(domain % configs, domain % namelist_filename, domain % dminfo) + else + call mpas_setup_namelists(domain % configs, nml_filename, domain % dminfo) + end if + + call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) + call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) + call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) + + call mpas_generate_packages(domain % packages) - if(present(calendar)) then - call mpas_timekeeping_init(calendar) + if (present(calendar)) then + call mpas_timekeeping_init(calendar) else - call mpas_timekeeping_init(config_calendar_type) + call mpas_timekeeping_init(config_calendar_type) end if pio_num_iotasks = config_pio_num_iotasks diff --git a/src/framework/mpas_grid_types.F b/src/framework/mpas_grid_types.F index 4ddd299295..210603533f 100644 --- a/src/framework/mpas_grid_types.F +++ b/src/framework/mpas_grid_types.F @@ -23,6 +23,8 @@ module mpas_grid_types use mpas_dmpar_types use mpas_attlist use mpas_packages + use mpas_io_units, only : stderrUnit + use mpas_timekeeping, only : MPAS_Clock_type integer, parameter :: nTimeLevs = 2 @@ -403,22 +405,132 @@ module mpas_grid_types end type field0DChar - ! Derived type for storing grid meta-data - type mesh_type - + ! Derived type for storing fields + type field0DLogical + + ! Back-pointer to the containing block type (block_type), pointer :: block -#include "field_dimensions.inc" - - logical :: on_a_sphere - real (kind=RKIND) :: sphere_radius - -#include "time_invariant_fields.inc" + ! Raw array holding field data on this block + logical :: scalar - end type mesh_type + ! 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() + logical :: hasTimeDimension + logical :: isActive + logical :: isVarArray + type (att_list_type), pointer :: attList => null() + ! Pointers to the prev and next blocks for this field on this task + type (field0DLogical), pointer :: prev, next -#include "variable_groups.inc" + ! 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 field0DLogical + + !!! TYPES FOR MPAS_POOL + integer, parameter :: MPAS_POOL_TABLE_SIZE = 128 + + integer, parameter :: MPAS_POOL_SILENT = 1001, & + MPAS_POOL_WARN = 1002, & + MPAS_POOL_FATAL = 1003 + + integer, parameter :: MPAS_POOL_FIELD = 1004, & + MPAS_POOL_CONFIG = 1005, & + MPAS_POOL_DIMENSION = 1006, & + MPAS_POOL_SUBPOOL = 1007, & + MPAS_POOL_PACKAGE = 1008 + + integer, parameter :: MPAS_POOL_REAL = 1009, & + MPAS_POOL_INTEGER = 1010, & + MPAS_POOL_LOGICAL = 1011, & + MPAS_POOL_CHARACTER = 1012 + + integer, parameter :: MPAS_DECOMP_NONDECOMP = 1013, & + MPAS_DECOMP_CELLS = 1014, & + MPAS_DECOMP_EDGES = 1015, & + MPAS_DECOMP_VERTICES = 1016 + + type mpas_pool_data_type + integer :: contentsType + integer :: contentsDims + integer :: contentsTimeLevs + + ! For storing fields + type (field0DReal), pointer :: r0 => null() + type (field1DReal), pointer :: r1 => null() + type (field2DReal), pointer :: r2 => null() + type (field3DReal), pointer :: r3 => null() + type (field4DReal), pointer :: r4 => null() + type (field5DReal), pointer :: r5 => null() + type (field0DReal), dimension(:), pointer :: r0a => null() + type (field1DReal), dimension(:), pointer :: r1a => null() + type (field2DReal), dimension(:), pointer :: r2a => null() + type (field3DReal), dimension(:), pointer :: r3a => null() + type (field4DReal), dimension(:), pointer :: r4a => null() + type (field5DReal), dimension(:), pointer :: r5a => null() + type (field0DInteger), pointer :: i0 => null() + type (field1DInteger), pointer :: i1 => null() + type (field2DInteger), pointer :: i2 => null() + type (field3DInteger), pointer :: i3 => null() + type (field0DInteger), dimension(:), pointer :: i0a => null() + type (field1DInteger), dimension(:), pointer :: i1a => null() + type (field2DInteger), dimension(:), pointer :: i2a => null() + type (field3DInteger), dimension(:), pointer :: i3a => null() + type (field0DChar), pointer :: c0 => null() + type (field1DChar), pointer :: c1 => null() + type (field0DChar), dimension(:), pointer :: c0a => null() + type (field1DChar), dimension(:), pointer :: c1a => null() + type (field0DLogical), pointer :: l0 => null() + type (field0DLogical), dimension(:), pointer :: l0a => null() + type (mpas_pool_type), pointer :: p => null() + + ! For storing config options, dimensions, and packages + integer, pointer :: simple_int => null() + integer, dimension(:), pointer :: simple_int_arr => null() + real(kind=RKIND), pointer :: simple_real => null() + logical, pointer :: simple_logical => null() + character(len=StrKIND), pointer :: simple_char => null() + end type mpas_pool_data_type + + type mpas_pool_member_type + character (len=StrKIND) :: key + integer :: keyLen + integer :: contentsType + type (mpas_pool_data_type), pointer :: data => null() + type (mpas_pool_member_type), pointer :: next => null() + end type mpas_pool_member_type + + type mpas_pool_head_type + type (mpas_pool_member_type), pointer :: head => null() + end type mpas_pool_head_type + + type mpas_pool_type + integer :: size + integer :: iteratorIndex + type (mpas_pool_head_type), dimension(:), pointer :: table => null() + type (mpas_pool_member_type), pointer :: iterator => null() + end type mpas_pool_type + + type mpas_pool_iterator_type + character (len=StrKIND) :: memberName + integer :: memberType + integer :: dataType + integer :: nDims + integer :: nTimeLevels + end type mpas_pool_iterator_type + + type mpas_pool_field_info_type + integer :: fieldType + integer :: nDims + integer :: nTimeLevels + logical :: isActive + end type mpas_pool_field_info_type + !!! END TYPES FOR MPAS POOL ! Type for storing (possibly architecture specific) information concerning to parallelism @@ -440,8 +552,6 @@ module mpas_grid_types ! Derived type for storing part of a domain; used as a basic unit of work for a process type block_type -#include "block_group_members.inc" - integer :: blockID ! Unique global ID number for this block integer :: localBlockID ! Unique local ID number for this block @@ -449,59 +559,202 @@ module mpas_grid_types type (parallel_info), pointer :: parinfo - type (block_type), pointer :: prev, next + type (block_type), pointer :: prev => null() + type (block_type), pointer :: next => null() + + type (mpas_pool_type), pointer :: structs, dimensions, configs, packages + type (mpas_pool_type), pointer :: allFields, allStructs end type block_type ! Derived type for storing list of blocks from a domain to be handled by a process type domain_type type (block_type), pointer :: blocklist + type (mpas_pool_type), pointer :: configs, packages + + type (MPAS_Clock_type), pointer :: clock ! Also store parallelization info here type (dm_info), pointer :: dminfo #include "model_variables.inc" + logical :: on_a_sphere + real (kind=RKIND) :: sphere_radius character (len=StrKIND*2) :: history !< History attribute, read in from input file. + character (len=StrKIND) :: mesh_id !< mesh_id attribute, randomly generated + character (len=StrKIND) :: Conventions !< Conventions attribute, read in from input file. + character (len=StrKIND) :: source !< source attribute, read in from input file. + character (len=StrKIND) :: mesh_spec !< mesh_spec attribute, read in from input file. + character (len=StrKIND) :: parent_id !< parent_id attribute, read in from input file. end type domain_type + interface mpas_allocate_mold + module procedure mpas_allocate_mold_1dreal + module procedure mpas_allocate_mold_2dreal + module procedure mpas_allocate_mold_3dreal + module procedure mpas_allocate_mold_4dreal + module procedure mpas_allocate_mold_5dreal + module procedure mpas_allocate_mold_1dinteger + module procedure mpas_allocate_mold_2dinteger + module procedure mpas_allocate_mold_3dinteger + module procedure mpas_allocate_mold_1dchar + end interface + + interface mpas_duplicate_field + module procedure mpas_duplicate_field0d_real + module procedure mpas_duplicate_field1d_real + module procedure mpas_duplicate_field2d_real + module procedure mpas_duplicate_field3d_real + module procedure mpas_duplicate_field4d_real + module procedure mpas_duplicate_field5d_real + module procedure mpas_duplicate_field0d_integer + module procedure mpas_duplicate_field1d_integer + module procedure mpas_duplicate_field2d_integer + module procedure mpas_duplicate_field3d_integer + module procedure mpas_duplicate_field0d_char + module procedure mpas_duplicate_field1d_char + module procedure mpas_duplicate_field0d_logical + end interface + + interface mpas_shift_time_levs + module procedure mpas_shift_time_levs_0dreal + module procedure mpas_shift_time_levs_1dreal + module procedure mpas_shift_time_levs_2dreal + module procedure mpas_shift_time_levs_3dreal + module procedure mpas_shift_time_levs_4dreal + module procedure mpas_shift_time_levs_5dreal + module procedure mpas_shift_time_levs_0dinteger + module procedure mpas_shift_time_levs_1dinteger + module procedure mpas_shift_time_levs_2dinteger + module procedure mpas_shift_time_levs_3dinteger + module procedure mpas_shift_time_levs_0dchar + module procedure mpas_shift_time_levs_1dchar + module procedure mpas_shift_time_levs_0dlogical + end interface + 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 + 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 + 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 - module procedure mpas_deallocate_field2d_integer - module procedure mpas_deallocate_field3d_integer - module procedure mpas_deallocate_field0d_real - 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 + module procedure mpas_deallocate_field0d_logical + module procedure mpas_deallocate_field0d_integer + module procedure mpas_deallocate_field1d_integer + module procedure mpas_deallocate_field2d_integer + module procedure mpas_deallocate_field3d_integer + module procedure mpas_deallocate_field0d_real + 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 + + interface mpas_pool_add_field + module procedure mpas_pool_add_field_0d_real + module procedure mpas_pool_add_field_1d_real + module procedure mpas_pool_add_field_2d_real + module procedure mpas_pool_add_field_3d_real + module procedure mpas_pool_add_field_4d_real + module procedure mpas_pool_add_field_5d_real + module procedure mpas_pool_add_field_0d_int + module procedure mpas_pool_add_field_1d_int + module procedure mpas_pool_add_field_2d_int + module procedure mpas_pool_add_field_3d_int + module procedure mpas_pool_add_field_0d_char + module procedure mpas_pool_add_field_1d_char + module procedure mpas_pool_add_field_0d_reals + module procedure mpas_pool_add_field_1d_reals + module procedure mpas_pool_add_field_2d_reals + module procedure mpas_pool_add_field_3d_reals + module procedure mpas_pool_add_field_4d_reals + module procedure mpas_pool_add_field_5d_reals + module procedure mpas_pool_add_field_0d_ints + module procedure mpas_pool_add_field_1d_ints + module procedure mpas_pool_add_field_2d_ints + module procedure mpas_pool_add_field_3d_ints + module procedure mpas_pool_add_field_0d_chars + module procedure mpas_pool_add_field_1d_chars + end interface + + interface mpas_pool_get_field + module procedure mpas_pool_get_field_0d_real + module procedure mpas_pool_get_field_1d_real + module procedure mpas_pool_get_field_2d_real + module procedure mpas_pool_get_field_3d_real + module procedure mpas_pool_get_field_4d_real + module procedure mpas_pool_get_field_5d_real + module procedure mpas_pool_get_field_0d_int + module procedure mpas_pool_get_field_1d_int + module procedure mpas_pool_get_field_2d_int + module procedure mpas_pool_get_field_3d_int + module procedure mpas_pool_get_field_0d_char + module procedure mpas_pool_get_field_1d_char + end interface + + interface mpas_pool_get_array + module procedure mpas_pool_get_array_0d_real + module procedure mpas_pool_get_array_1d_real + module procedure mpas_pool_get_array_2d_real + module procedure mpas_pool_get_array_3d_real + module procedure mpas_pool_get_array_4d_real + module procedure mpas_pool_get_array_5d_real + module procedure mpas_pool_get_array_0d_int + module procedure mpas_pool_get_array_1d_int + module procedure mpas_pool_get_array_2d_int + module procedure mpas_pool_get_array_3d_int + module procedure mpas_pool_get_array_0d_char + module procedure mpas_pool_get_array_1d_char + end interface + + interface mpas_pool_add_config + module procedure mpas_pool_add_config_real + module procedure mpas_pool_add_config_int + module procedure mpas_pool_add_config_char + module procedure mpas_pool_add_config_logical + end interface + + interface mpas_pool_get_config + module procedure mpas_pool_get_config_real + module procedure mpas_pool_get_config_int + module procedure mpas_pool_get_config_char + module procedure mpas_pool_get_config_logical + end interface + + interface mpas_pool_add_dimension + module procedure mpas_pool_add_dimension_0d + module procedure mpas_pool_add_dimension_1d + end interface + + interface mpas_pool_get_dimension + module procedure mpas_pool_get_dimension_0d + module procedure mpas_pool_get_dimension_1d end interface + integer :: currentErrorLevel = MPAS_POOL_SILENT + + contains @@ -523,10 +776,16 @@ subroutine mpas_allocate_domain(dom, dminfo)!{{{ type (domain_type), pointer :: dom !< Input/Output: Domain structure type (dm_info), pointer :: dminfo !< Input: Domain Information - allocate(dom) nullify(dom % blocklist) dom % dminfo => dminfo + allocate(dom % configs) + allocate(dom % packages) + allocate(dom % clock) + + call mpas_pool_create_pool(dom % configs) + call mpas_pool_create_pool(dom % packages) + end subroutine mpas_allocate_domain!}}} !*********************************************************************** @@ -551,9 +810,7 @@ subroutine mpas_allocate_block(nHaloLayers, b, dom, blockID, &!{{{ type (block_type), pointer :: b !< Input/Output: Block structure type (domain_type), pointer :: dom !< Input: Domain structure integer, intent(in) :: blockID !< Input: Global ID of block -#include "dim_dummy_decls.inc" - - +#include "dim_dummy_defines_input.inc" integer :: i @@ -563,14 +820,19 @@ subroutine mpas_allocate_block(nHaloLayers, b, dom, blockID, &!{{{ b % domain => dom -#include "block_allocs.inc" - - end subroutine mpas_allocate_block!}}} + allocate(b % structs) + allocate(b % dimensions) + allocate(b % allFields) + call mpas_pool_create_pool(b % structs) + call mpas_pool_create_pool(b % dimensions) + call mpas_pool_create_pool(b % allFields) + call mpas_pool_create_pool(b % allStructs) + b % configs => dom % configs + b % packages => dom % packages -#include "group_alloc_routines.inc" + end subroutine mpas_allocate_block!}}} -#include "provis_alloc_routines.inc" !*********************************************************************** ! @@ -597,7 +859,9 @@ subroutine mpas_deallocate_domain(dom)!{{{ block_ptr => block_ptr % next end do - deallocate(dom) + call mpas_pool_destroy_pool(dom % configs) + call mpas_pool_destroy_pool(dom % packages) + deallocate(dom % clock) end subroutine mpas_deallocate_domain!}}} @@ -1384,6 +1648,40 @@ subroutine mpas_deallocate_scratch_field1d_char(f, single_block_in)!{{{ end subroutine mpas_deallocate_scratch_field1d_char!}}} +!*********************************************************************** +! +! routine mpas_deallocate_field0d_logical +! +!> \brief MPAS 0D logical deallocation routine. +!> \author Doug Jacobsen +!> \date 04/02/13 +!> \details +!> This routine deallocates a 0D logical field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_logical(f)!{{{ + type (field0dLogical), pointer :: f !< Input: Field to deallocate + type (field0dLogical), 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 + + deallocate(f_cursor) + f_cursor => f + end do + + end subroutine mpas_deallocate_field0d_logical!}}} + !*********************************************************************** ! ! routine mpas_deallocate_field0d_integer @@ -1852,6 +2150,9 @@ subroutine mpas_deallocate_block(b)!{{{ ! deallocate the array of head pointers and the parinfo type... ! It also seems like these deallocations should happen with mpas_dmpar_destroy_multihalo_exchange_list + call mpas_pool_destroy_pool(b % structs) + call mpas_pool_destroy_pool(b % dimensions) + deallocate(b % parinfo % cellsToSend) deallocate(b % parinfo % cellsToRecv) deallocate(b % parinfo % cellsToCopy) @@ -1866,21 +2167,1055 @@ subroutine mpas_deallocate_block(b)!{{{ deallocate(b % parinfo) -#include "block_deallocs.inc" - end subroutine mpas_deallocate_block!}}} -#include "group_dealloc_routines.inc" +!*********************************************************************** +! +! routine mpas_allocate_mold_1dreal +! +!> \brief Allocates a 1-d real array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_1dreal(dst, src) + + implicit none + + real(kind=RKIND), dimension(:), pointer :: dst + real(kind=RKIND), dimension(:), intent(in) :: src + + allocate(dst(size(src))) + + end subroutine mpas_allocate_mold_1dreal + + +!*********************************************************************** +! +! routine mpas_allocate_mold_2dreal +! +!> \brief Allocates a 2-d real array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_2dreal(dst, src) + + implicit none + + real(kind=RKIND), dimension(:,:), pointer :: dst + real(kind=RKIND), dimension(:,:), intent(in) :: src + + integer, dimension(2) :: dims + + dims = shape(src) + + allocate(dst(dims(1),dims(2))) + + end subroutine mpas_allocate_mold_2dreal + + +!*********************************************************************** +! +! routine mpas_allocate_mold_3dreal +! +!> \brief Allocates a 3-d real array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_3dreal(dst, src) + + implicit none + + real(kind=RKIND), dimension(:,:,:), pointer :: dst + real(kind=RKIND), dimension(:,:,:), intent(in) :: src + + integer, dimension(3) :: dims + + dims = shape(src) + + allocate(dst(dims(1),dims(2),dims(3))) + + end subroutine mpas_allocate_mold_3dreal + + +!*********************************************************************** +! +! routine mpas_allocate_mold_4dreal +! +!> \brief Allocates a 4-d real array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_4dreal(dst, src) + + implicit none + + real(kind=RKIND), dimension(:,:,:,:), pointer :: dst + real(kind=RKIND), dimension(:,:,:,:), intent(in) :: src + + integer, dimension(4) :: dims + + dims = shape(src) + + allocate(dst(dims(1),dims(2),dims(3),dims(4))) + + end subroutine mpas_allocate_mold_4dreal + + +!*********************************************************************** +! +! routine mpas_allocate_mold_5dreal +! +!> \brief Allocates a 5-d real array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_5dreal(dst, src) + + implicit none + + real(kind=RKIND), dimension(:,:,:,:,:), pointer :: dst + real(kind=RKIND), dimension(:,:,:,:,:), intent(in) :: src + + integer, dimension(5) :: dims + + dims = shape(src) + + allocate(dst(dims(1),dims(2),dims(3),dims(4),dims(5))) + + end subroutine mpas_allocate_mold_5dreal + + +!*********************************************************************** +! +! routine mpas_allocate_mold_1dinteger +! +!> \brief Allocates a 1-d integer array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_1dinteger(dst, src) + + implicit none + + integer, dimension(:), pointer :: dst + integer, dimension(:), intent(in) :: src + + allocate(dst(size(src))) + + end subroutine mpas_allocate_mold_1dinteger + + +!*********************************************************************** +! +! routine mpas_allocate_mold_2dinteger +! +!> \brief Allocates a 2-d integer array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_2dinteger(dst, src) + + implicit none + + integer, dimension(:,:), pointer :: dst + integer, dimension(:,:), intent(in) :: src + + integer, dimension(2) :: dims + + dims = shape(src) + + allocate(dst(dims(1),dims(2))) + + end subroutine mpas_allocate_mold_2dinteger + + +!*********************************************************************** +! +! routine mpas_allocate_mold_3dinteger +! +!> \brief Allocates a 3-d integer array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_3dinteger(dst, src) + + implicit none + + integer, dimension(:,:,:), pointer :: dst + integer, dimension(:,:,:), intent(in) :: src + + integer, dimension(3) :: dims + + dims = shape(src) + + allocate(dst(dims(1),dims(2),dims(3))) + + end subroutine mpas_allocate_mold_3dinteger + + +!*********************************************************************** +! +! routine mpas_allocate_mold_1dchar +! +!> \brief Allocates a 1-d character array using the dimensions of another array +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Allocates the array dst to have the same dimensions as the array src. +!> This routine exists to provide the same functionality as F2008's +!> ALLOCATE(A,MOLD=B) functionality, or a similar functionality to F2003's +!> ALLOCATE(A,SOURCE=B) but without actually copying the source values. +! +!----------------------------------------------------------------------- + subroutine mpas_allocate_mold_1dchar(dst, src) + + implicit none + + character(len=StrKIND), dimension(:), pointer :: dst + character(len=StrKIND), dimension(:), intent(in) :: src + + allocate(dst(size(src))) + + end subroutine mpas_allocate_mold_1dchar + + +!*********************************************************************** +! +! routine mpas_duplicate_field0d_real +! +!> \brief MPAS 0D real field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field0d_real(src, dst, copy_array_only) !{{{ + + implicit none + + type (field0DReal), intent(in), target :: src !< Input: Field to be duplicated + type (field0DReal), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field0DReal), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_scalar.inc" + + end subroutine mpas_duplicate_field0d_real !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field1d_real +! +!> \brief MPAS 1D real field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field1d_real(src, dst, copy_array_only) !{{{ + + implicit none + + type (field1DReal), intent(in), target :: src !< Input: Field to be duplicated + type (field1DReal), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field1DReal), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field1d_real !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field2d_real +! +!> \brief MPAS 2D real field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field2d_real(src, dst, copy_array_only) !{{{ + + implicit none + + type (field2DReal), intent(in), target :: src !< Input: Field to be duplicated + type (field2DReal), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field2DReal), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field2d_real !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field3d_real +! +!> \brief MPAS 3D real field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field3d_real(src, dst, copy_array_only) !{{{ + + implicit none + + type (field3DReal), intent(in), target :: src !< Input: Field to be duplicated + type (field3DReal), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field3DReal), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field3d_real !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field4d_real +! +!> \brief MPAS 4D real field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field4d_real(src, dst, copy_array_only) !{{{ + + implicit none + + type (field4DReal), intent(in), target :: src !< Input: Field to be duplicated + type (field4DReal), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field4DReal), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field4d_real !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field5d_real +! +!> \brief MPAS 5D real field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field5d_real(src, dst, copy_array_only) !{{{ + + implicit none + + type (field5DReal), intent(in), target :: src !< Input: Field to be duplicated + type (field5DReal), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field5DReal), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field5d_real !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field0d_integer +! +!> \brief MPAS 0D integer field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field0d_integer(src, dst, copy_array_only) !{{{ + + implicit none + + type (field0DInteger), intent(in), target :: src !< Input: Field to be duplicated + type (field0DInteger), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field0DInteger), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_scalar.inc" + + end subroutine mpas_duplicate_field0d_integer !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field1d_integer +! +!> \brief MPAS 1D integer field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field1d_integer(src, dst, copy_array_only) !{{{ + + implicit none + + type (field1DInteger), intent(in), target :: src !< Input: Field to be duplicated + type (field1DInteger), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field1DInteger), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field1d_integer !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field2d_integer +! +!> \brief MPAS 2D integer field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field2d_integer(src, dst, copy_array_only) !{{{ + + implicit none + + type (field2DInteger), intent(in), target :: src !< Input: Field to be duplicated + type (field2DInteger), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field2DInteger), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field2d_integer !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field3d_integer +! +!> \brief MPAS 3D integer field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field3d_integer(src, dst, copy_array_only) !{{{ + + implicit none + + type (field3DInteger), intent(in), target :: src !< Input: Field to be duplicated + type (field3DInteger), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field3DInteger), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field3d_integer !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field0d_char +! +!> \brief MPAS 0D character field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field0d_char(src, dst, copy_array_only) !{{{ + + implicit none + + type (field0DChar), intent(in), target :: src !< Input: Field to be duplicated + type (field0DChar), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field0DChar), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_scalar.inc" + + end subroutine mpas_duplicate_field0d_char !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field1d_char +! +!> \brief MPAS 1D character field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field1d_char(src, dst, copy_array_only) !{{{ + + implicit none + + type (field1DChar), intent(in), target :: src !< Input: Field to be duplicated + type (field1DChar), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field1DChar), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_array.inc" + + end subroutine mpas_duplicate_field1d_char !}}} + + +!*********************************************************************** +! +! routine mpas_duplicate_field0d_logical +! +!> \brief MPAS 0D logical field duplication routine. +!> \author Michael Duda +!> \date 04/12/14 +!> \details +!> Creates a duplicate of the source field. +! +!----------------------------------------------------------------------- + subroutine mpas_duplicate_field0d_logical(src, dst, copy_array_only) !{{{ + + implicit none + + type (field0DLogical), intent(in), target :: src !< Input: Field to be duplicated + type (field0DLogical), pointer :: dst !< Output: Field to contain the duplicate + logical, intent(in), optional :: copy_array_only !< Input: whether to assume that dst exists, and only copy array data + + type (field0DLogical), pointer :: src_cursor, dst_cursor + logical :: local_copy_only + +#include "duplicate_field_scalar.inc" + + end subroutine mpas_duplicate_field0d_logical !}}} + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_0dreal +! +!> \brief MPAS 0D real time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_0dreal(fldarr) + + implicit none + + type (field0DReal), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field0DReal), dimension(:), pointer :: fldarr_ptr + real(kind=RKIND) :: scalar + +#include "shift_time_levs_scalar.inc" + + end subroutine mpas_shift_time_levs_0dreal + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_1dreal +! +!> \brief MPAS 1D real time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_1dreal(fldarr) + + implicit none + + type (field1DReal), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field1DReal), dimension(:), pointer :: fldarr_ptr + real(kind=RKIND), dimension(:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_1dreal + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_2dreal +! +!> \brief MPAS 2D real time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_2dreal(fldarr) + + implicit none + + type (field2DReal), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field2DReal), dimension(:), pointer :: fldarr_ptr + real(kind=RKIND), dimension(:,:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_2dreal + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_3dreal +! +!> \brief MPAS 3D real time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_3dreal(fldarr) + + implicit none + + type (field3DReal), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field3DReal), dimension(:), pointer :: fldarr_ptr + real(kind=RKIND), dimension(:,:,:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_3dreal + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_4dreal +! +!> \brief MPAS 4D real time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_4dreal(fldarr) + + implicit none + + type (field4DReal), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field4DReal), dimension(:), pointer :: fldarr_ptr + real(kind=RKIND), dimension(:,:,:,:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_4dreal + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_5dreal +! +!> \brief MPAS 5D real time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_5dreal(fldarr) + + implicit none + + type (field5DReal), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field5DReal), dimension(:), pointer :: fldarr_ptr + real(kind=RKIND), dimension(:,:,:,:,:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_5dreal + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_0dinteger +! +!> \brief MPAS 0D integer time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_0dinteger(fldarr) + + implicit none + + type (field0DInteger), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field0DInteger), dimension(:), pointer :: fldarr_ptr + integer :: scalar + +#include "shift_time_levs_scalar.inc" + + end subroutine mpas_shift_time_levs_0dinteger + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_1dinteger +! +!> \brief MPAS 1D integer time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_1dinteger(fldarr) + + implicit none + + type (field1DInteger), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field1DInteger), dimension(:), pointer :: fldarr_ptr + integer, dimension(:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_1dinteger + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_2dinteger +! +!> \brief MPAS 2D integer time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_2dinteger(fldarr) + + implicit none + + type (field2DInteger), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field2DInteger), dimension(:), pointer :: fldarr_ptr + integer, dimension(:,:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_2dinteger + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_3dinteger +! +!> \brief MPAS 3D integer time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_3dinteger(fldarr) + + implicit none + + type (field3DInteger), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field3DInteger), dimension(:), pointer :: fldarr_ptr + integer, dimension(:,:,:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_3dinteger + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_0dchar +! +!> \brief MPAS 0D character time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_0dchar(fldarr) + + implicit none + + type (field0DChar), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field0DChar), dimension(:), pointer :: fldarr_ptr + character (len=StrKIND) :: scalar + +#include "shift_time_levs_scalar.inc" + + end subroutine mpas_shift_time_levs_0dchar + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_1dchar +! +!> \brief MPAS 1D character time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_1dchar(fldarr) + + implicit none + + type (field1DChar), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field1DChar), dimension(:), pointer :: fldarr_ptr + character (len=StrKIND), dimension(:), pointer :: arr_ptr + +#include "shift_time_levs_array.inc" + + end subroutine mpas_shift_time_levs_1dchar + + +!*********************************************************************** +! +! routine mpas_shift_time_levs_0dlogical +! +!> \brief MPAS 0D logical time-level shift routine +!> \author Michael Duda +!> \date 04/14/14 +!> \details +!> Shifts the contents of the array of fields provided by the input argument. +!> After returning, the storage for fldarr(n) will point to what was the storage +!> for fldarr(n+1) in a period fashion, so that, for N time levels, the storage +!> for fldarr(N) will point to what was the storage for fldarr(1). +! +!----------------------------------------------------------------------- + subroutine mpas_shift_time_levs_0dlogical(fldarr) + + implicit none + + type (field0DLogical), dimension(:), pointer :: fldarr + + integer :: i, nlevs + type (field0DLogical), dimension(:), pointer :: fldarr_ptr + logical :: scalar + +#include "shift_time_levs_scalar.inc" + + end subroutine mpas_shift_time_levs_0dlogical + +!*********************************************************************** +! +! routine mpas_link_fields +! +!> \brief MPAS Link Fields routine +!> \author Doug Jacobsen +!> \date 04/24/2014 +!> \details +!> Sets up field links across blocks. This routine should be called prior to +!> any halo exchanges. Also links parinfo into each field. +! +!----------------------------------------------------------------------- + subroutine mpas_link_fields(domain)!{{{ + type (domain_type), intent(in) :: domain + + type (block_type), pointer :: blockPtr + type (block_type), pointer :: prevBlock + type (block_type), pointer :: nextBlock + + blockPtr => domain % blocklist + do while(associated(blockPtr)) + if (associated(blockPtr % prev)) then + prevBlock => blockPtr % prev + else + nullify(prevBlock) + end if + + if (associated(blockPtr % next)) then + nextBlock => blockPtr % next + else + nullify(nextBlock) + end if + + if (associated(prevBlock) .and. associated(nextBlock)) then + call mpas_pool_link_pools(blockPtr % structs, prevBlock % structs, nextBlock % structs) + else if (associated(prevBlock)) then + call mpas_pool_link_pools(blockPtr % structs, prevBlock % structs) + else if (associated(nextBlock)) then + call mpas_pool_link_pools(blockPtr % structs, nextPool=nextBlock % structs) + else + call mpas_pool_link_pools(blockPtr % structs) + end if + + call mpas_pool_link_parinfo(blockPtr, blockPtr % structs) + + blockPtr => blockPtr % next + end do + + end subroutine mpas_link_fields!}}} + -#include "group_copy_routines.inc" -#include "group_shift_level_routines.inc" +#include "pool_subroutines.inc" -#include "field_links.inc" +#include "define_dimensions.inc" +#include "define_packages.inc" +!#include "link_fields.inc" +#include "structs_and_variables.inc" end module mpas_grid_types diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 59fdbbd695..995c262119 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -16,6 +16,7 @@ module mpas_io use pionfatt_mod use pio_types + #ifdef SINGLE_PRECISION integer, parameter :: PIO_REALKIND = PIO_REAL #else @@ -37,6 +38,15 @@ module mpas_io MPAS_IO_LOGICAL = 8, & MPAS_IO_CHAR = 9 + ! Field precision + integer, parameter :: MPAS_IO_SINGLE_PRECISION = 10, & + MPAS_IO_DOUBLE_PRECISION = 11, & +#ifdef SINGLE_PRECISION + MPAS_IO_NATIVE_PRECISION = MPAS_IO_SINGLE_PRECISION +#else + MPAS_IO_NATIVE_PRECISION = MPAS_IO_DOUBLE_PRECISION +#endif + ! Unlimited / record dimension integer, parameter :: MPAS_IO_UNLIMITED_DIM = -123456 @@ -59,17 +69,20 @@ module mpas_io MPAS_IO_ERR_TWO_UNLIMITED_DIMS = -15, & MPAS_IO_ERR_WRONG_MODE = -16, & MPAS_IO_ERR_NO_UNLIMITED_DIM = -17, & - MPAS_IO_ERR_UNIMPLEMENTED = -18 + MPAS_IO_ERR_UNIMPLEMENTED = -18, & + MPAS_IO_ERR_WOULD_CLOBBER = -19 type MPAS_IO_Handle_type logical :: initialized = .false. + logical :: preexisting_file = .false. logical :: data_mode = .false. type (file_desc_t) :: pio_file character (len=StrKIND) :: filename integer :: iomode integer :: ioformat integer :: pio_unlimited_dimid + integer :: preexisting_records = 0 integer (kind=PIO_offset) :: frame_number = 1 type (dimlist_type), pointer :: dimlist_head => null() type (dimlist_type), pointer :: dimlist_tail => null() @@ -166,6 +179,7 @@ module mpas_io integer :: field_type logical :: has_unlimited_dim = .false. integer :: ndims + integer :: precision type (dimhandle_type), pointer, dimension(:) :: dims type (attlist_type), pointer :: attlist_head => null() type (attlist_type), pointer :: attlist_tail => null() @@ -200,6 +214,7 @@ module mpas_io contains + subroutine MPAS_io_init(dminfo, io_task_count, io_task_stride, io_system, ierr) implicit none @@ -215,18 +230,18 @@ subroutine MPAS_io_init(dminfo, io_task_count, io_task_stride, io_system, ierr) local_dminfo = dminfo - if(present(io_system)) then - pio_iosystem => io_system + if (present(io_system)) then + pio_iosystem => io_system else !write(stderrUnit,*) 'MGD PIO_init' - 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 + 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 end if @@ -258,6 +273,7 @@ subroutine MPAS_io_set_iotype(io_type_in, ierr) end if master_pio_iotype = io_type_in + end subroutine MPAS_io_set_iotype @@ -284,22 +300,39 @@ subroutine MPAS_io_unset_iotype(ierr) end if master_pio_iotype = -999 + end subroutine MPAS_io_unset_iotype + - type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ierr) + type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, clobber_file, truncate_file, ierr) implicit none character (len=*), intent(in) :: filename integer, intent(in) :: mode integer, intent(in) :: ioformat + logical, intent(in), optional :: clobber_file + logical, intent(in), optional :: truncate_file integer, intent(out), optional :: ierr integer :: pio_ierr, pio_iotype + logical :: local_clobber, local_truncate + logical :: exists ! write(stderrUnit,*) 'Called MPAS_io_open()' if (present(ierr)) ierr = MPAS_IO_NOERR + if (present(clobber_file)) then + local_clobber = clobber_file + else + local_clobber = .false. + end if + + if (present(truncate_file)) then + local_truncate = truncate_file + else + local_truncate = .false. + end if ! Sanity checks if (mode /= MPAS_IO_READ .and. & @@ -333,7 +366,23 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ierr) if (mode == MPAS_IO_WRITE) then !write(stderrUnit,*) 'MGD PIO_createfile' - pio_ierr = PIO_createfile(pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_64BIT_OFFSET) + inquire(file=trim(filename), exist=exists) + + ! If the file exists and we are not allowed to clobber it, return an + ! appropriate error code + if (exists .and. (.not. local_clobber)) then + if (present(ierr)) ierr = MPAS_IO_ERR_WOULD_CLOBBER + end if + + if (exists .and. (.not. local_truncate)) then + pio_ierr = PIO_openfile(pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_write) + MPAS_io_open % preexisting_file = .true. + else + pio_ierr = PIO_createfile(pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_64BIT_OFFSET) + if (exists) then + write(stderrUnit,'(a)') 'MPAS I/O: Truncating existing data in output file '//trim(filename) + end if + end if else !write(stderrUnit,*) 'MGD PIO_openfile' pio_ierr = PIO_openfile(pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_nowrite) @@ -343,7 +392,7 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ierr) return end if - if (mode == MPAS_IO_READ) then + if (mode == MPAS_IO_READ .or. MPAS_io_open % preexisting_file) then !MPAS_io_open % pio_unlimited_dimid = 44 pio_ierr = PIO_inquire(MPAS_io_open % pio_file, unlimitedDimID=MPAS_io_open % pio_unlimited_dimid) !write(stderrUnit,*) 'Found unlimited dim ', MPAS_io_open % pio_unlimited_dimid @@ -351,6 +400,12 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ierr) if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if + + pio_ierr = PIO_inq_dimlen(MPAS_io_open % pio_file, MPAS_io_open % pio_unlimited_dimid, MPAS_io_open % preexisting_records) + if (pio_ierr /= PIO_noerr) then + if (present(ierr)) ierr = MPAS_IO_ERR_PIO + return + end if end if MPAS_io_open % initialized = .true. @@ -485,6 +540,7 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: inq_dimsize type (dimlist_type), pointer :: new_dimlist_node type (dimlist_type), pointer :: dim_cursor @@ -512,7 +568,12 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) dim_cursor => handle % dimlist_head do while (associated(dim_cursor)) if (trim(dimname) == trim(dim_cursor % dimhandle % dimname)) then - if (dimsize /= dim_cursor % dimhandle % dimsize) then + + ! The second half of the test below avoids raising errors in the case where + ! we are writing to an already existing file, in which case the dimlen for the + ! unlimited dimension in the file will generally not be MPAS_IO_UNLIMITED_DIM + if ((dimsize /= dim_cursor % dimhandle % dimsize) .and. & + .not. (dimsize == MPAS_IO_UNLIMITED_DIM .and. dim_cursor % dimhandle % is_unlimited_dim)) then if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_DIM end if return @@ -527,6 +588,26 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) end do + ! + ! If we're working with a preexisting file, see whether this dimension isn't already + ! defined in the file; if it is, the dimension should match the dimsize specified in + ! this call to define the dimension, at which point we can add it to our local cache + ! + if (handle % preexisting_file) then + call MPAS_io_inq_dim(handle, dimname, inq_dimsize, ierr=pio_ierr) + if (pio_ierr /= MPAS_IO_ERR_PIO) then + + ! Verify that the dimsize matches... + if (dimsize /= inq_dimsize .and. dimsize /= MPAS_IO_UNLIMITED_DIM) then + if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_DIM + return + end if + + end if + return + end if + + ! ! Otherwise, define it ! @@ -587,6 +668,7 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz logical :: found integer :: pio_ierr + ! write(stderrUnit,*) 'Called MPAS_io_inq_var()' if (present(ierr)) ierr = MPAS_IO_NOERR @@ -645,10 +727,13 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz !write(stderrUnit,*) 'Inquired about variable type', new_fieldlist_node % fieldhandle % field_type ! Convert to MPAS type + new_fieldlist_node % fieldhandle % precision = MPAS_IO_NATIVE_PRECISION if (new_fieldlist_node % fieldhandle % field_type == PIO_double) then new_fieldlist_node % fieldhandle % field_type = MPAS_IO_DOUBLE + new_fieldlist_node % fieldhandle % precision = MPAS_IO_DOUBLE_PRECISION else if (new_fieldlist_node % fieldhandle % field_type == PIO_real) then new_fieldlist_node % fieldhandle % field_type = MPAS_IO_REAL + new_fieldlist_node % fieldhandle % precision = MPAS_IO_SINGLE_PRECISION else if (new_fieldlist_node % fieldhandle % field_type == PIO_int) then new_fieldlist_node % fieldhandle % field_type = MPAS_IO_INT else if (new_fieldlist_node % fieldhandle % field_type == PIO_char) then @@ -786,7 +871,7 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz end subroutine MPAS_io_inq_var - subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, ierr) + subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ierr) implicit none @@ -794,16 +879,22 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, ierr) character (len=*), intent(in) :: fieldname integer, intent(in) :: fieldtype character (len=StrKIND), dimension(:), intent(in) :: dimnames + integer, intent(in), optional :: precision integer, intent(out), optional :: ierr integer :: i integer :: pio_ierr integer :: pio_type integer :: ndims + integer :: inq_fieldtype + integer :: inq_ndims + character (len=StrKIND), dimension(:), pointer :: inq_dimnames type (fieldlist_type), pointer :: new_fieldlist_node type (fieldlist_type), pointer :: field_cursor type (dimlist_type), pointer :: dim_cursor integer, dimension(:), pointer :: dimids + integer :: local_precision + ! write(stderrUnit,*) 'Called MPAS_io_def_var()' if (present(ierr)) ierr = MPAS_IO_NOERR @@ -823,6 +914,16 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, ierr) end if + ! + ! Set precision to be use for reading/writing + ! + if (present(precision)) then + local_precision = precision + else + local_precision = MPAS_IO_NATIVE_PRECISION + end if + + ! ! Check whether this field has already been defined ! @@ -846,6 +947,54 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, ierr) field_cursor => field_cursor % next end do + + ! + ! If we're working with a preexisting file, see whether this variable isn't already + ! defined in the file; if it is, the type and dimensions should match the type and dimensions + ! specified in this call to define the variable, at which point we can add it to our local cache + ! + if (handle % preexisting_file) then + call MPAS_io_inq_var(handle, fieldname, inq_fieldtype, inq_ndims, inq_dimnames, ierr=pio_ierr) + if (pio_ierr /= MPAS_IO_ERR_PIO) then + + ! Verify that the type and dimensions matche... + if (fieldtype == MPAS_IO_DOUBLE) then + if (local_precision == MPAS_IO_SINGLE_PRECISION) then + pio_type = MPAS_IO_REAL + else + pio_type = MPAS_IO_DOUBLE + end if + else + pio_type = fieldtype + end if + if (pio_type /= inq_fieldtype) then + if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_DIM + deallocate(inq_dimnames) + return + end if + + if (ndims /= inq_ndims) then + if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_DIM + deallocate(inq_dimnames) + return + end if + + do i=1,ndims + if (trim(dimnames(i)) /= trim(inq_dimnames(i))) then + if (present(ierr)) ierr = MPAS_IO_ERR_REDEF_DIM + deallocate(inq_dimnames) + return + end if + end do + + ! TODO: Can we get the dimension sizes to see whether they match those from the file? + + end if + + return + end if + + ! ! Otherwise, define it ! @@ -856,6 +1005,7 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, ierr) new_fieldlist_node % fieldhandle % fieldname = fieldname new_fieldlist_node % fieldhandle % field_type = fieldtype new_fieldlist_node % fieldhandle % ndims = ndims + new_fieldlist_node % fieldhandle % precision = local_precision allocate(dimids(ndims)) allocate(new_fieldlist_node % fieldhandle % dims(ndims)) @@ -885,8 +1035,14 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, ierr) ! Convert from MPAS type if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_DOUBLE) then - pio_type = PIO_double + if (local_precision == MPAS_IO_SINGLE_PRECISION) then + pio_type = PIO_real + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_REAL + else + pio_type = PIO_double + end if else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_REAL) then + !TODO: handle up-conversion from single-precision to double-precision in file? pio_type = PIO_real else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_INT) then pio_type = PIO_int @@ -1084,6 +1240,19 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) end do ! Type and dimensions match... what about indices? + if (size(decomp_cursor % decomphandle % indices) /= size(indices)) then +!write(stderrUnit,*) 'We do not have the same number of indices in this decomposition...' + decomp_cursor => decomp_cursor % next + cycle DECOMP_LOOP + end if + + do i=1,size(decomp_cursor % decomphandle % indices) + if (indices(i) /= decomp_cursor % decomphandle % indices(i)) then +!write(stderrUnit,*) 'One of the indices does not match... ', i + decomp_cursor => decomp_cursor % next + cycle DECOMP_LOOP + end if + end do ! OK, we have a match... just use this decomposition for the field and return field_cursor % fieldhandle % decomp => decomp_cursor % decomphandle @@ -1244,9 +1413,24 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr integer, dimension(1) :: count1 integer, dimension(2) :: start2 integer, dimension(2) :: count2 + integer, dimension(3) :: start3 + integer, dimension(3) :: count3 + integer, dimension(4) :: start4 + integer, dimension(4) :: count4 + integer, dimension(5) :: start5 + integer, dimension(5) :: count5 + integer, dimension(6) :: start6 + integer, dimension(6) :: count6 character (len=StrKIND), dimension(1) :: tempchar type (fieldlist_type), pointer :: field_cursor + real (kind=R4KIND) :: singleVal + real (kind=R4KIND), dimension(:), allocatable :: singleArray1d + real (kind=R4KIND), dimension(:,:), allocatable :: singleArray2d + real (kind=R4KIND), dimension(:,:,:), allocatable :: singleArray3d + real (kind=R4KIND), dimension(:,:,:,:), allocatable :: singleArray4d + real (kind=R4KIND), dimension(:,:,:,:,:), allocatable :: singleArray5d + ! Sanity checks if (.not. handle % initialized) then if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE @@ -1271,18 +1455,6 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr return end if - - ! - ! Check that we have a decomposition for this field - ! -! write(stderrUnit,*) 'Checking for decomposition' - if (.not.present(intVal) .and. .not.present(realVal) .and. .not.present(charVal)) then - if (.not. associated(field_cursor % fieldhandle % decomp)) then - if (present(ierr)) ierr = MPAS_IO_ERR_NO_DECOMP - return - end if - end if - !!!! Assume array was already allocated by the user ! write(stderrUnit,*) 'Checking for unlimited dim' @@ -1299,10 +1471,20 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr ! write(stderrUnit,*) 'Checking for real, int, char, etc' if (present(realVal)) then ! write (0,*) ' value is real' - if (field_cursor % fieldhandle % has_unlimited_dim) then - pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + if (field_cursor % fieldhandle % has_unlimited_dim) then + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, singleVal) + else + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, singleVal) + end if + realVal = real(singleVal,RKIND) else - pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal) + if (field_cursor % fieldhandle % has_unlimited_dim) then + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal) + else + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal) + end if end if else if (present(intVal)) then ! write (0,*) ' value is int' @@ -1325,40 +1507,333 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr end if else if (present(realArray1d)) then ! write (0,*) ' value is real1' - call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - realArray1d, pio_ierr) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray1d(size(realArray1d,1))) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray1d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start2(1) = 1 + start2(2) = handle % frame_number + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, singleArray1d) + else + start1(:) = 1 + count1(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, singleArray1d) + end if + end if + realArray1d(:) = real(singleArray1d(:),RKIND) + deallocate(singleArray1d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray1d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start2(1) = 1 + start2(2) = handle % frame_number + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, realArray1d) + else + start1(:) = 1 + count1(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, realArray1d) + end if + end if + end if else if (present(realArray2d)) then ! write (0,*) ' value is real2' - call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - realArray2d, pio_ierr) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray2d(size(realArray2d,1), size(realArray2d,2))) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray2d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start3(:) = 1 + start3(3) = handle % frame_number + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, singleArray2d) + else + start2(:) = 1 + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = field_cursor % fieldhandle % dims(2) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, singleArray2d) + end if + end if + realArray2d(:,:) = real(singleArray2d(:,:),RKIND) + deallocate(singleArray2d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray2d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start3(:) = 1 + start3(3) = handle % frame_number + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, realArray2d) + else + start2(:) = 1 + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = field_cursor % fieldhandle % dims(2) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, realArray2d) + end if + end if + end if else if (present(realArray3d)) then ! write (0,*) ' value is real3' - call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - realArray3d, pio_ierr) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray3d(size(realArray3d,1),size(realArray3d,2),size(realArray3d,3))) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray3d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start4(:) = 1 + start4(4) = handle % frame_number + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, singleArray3d) + else + start3(:) = 1 + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = field_cursor % fieldhandle % dims(3) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, singleArray3d) + end if + end if + realArray3d(:,:,:) = real(singleArray3d(:,:,:),RKIND) + deallocate(singleArray3d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray3d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start4(:) = 1 + start4(4) = handle % frame_number + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, realArray3d) + else + start3(:) = 1 + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = field_cursor % fieldhandle % dims(3) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, realArray3d) + end if + end if + end if else if (present(realArray4d)) then ! write (0,*) ' value is real4' - call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - realArray4d, pio_ierr) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray4d(size(realArray4d,1),size(realArray4d,2),size(realArray4d,3),size(realArray4d,4))) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray4d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start5(:) = 1 + start5(5) = handle % frame_number + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, singleArray4d) + else + start4(:) = 1 + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = field_cursor % fieldhandle % dims(4) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, singleArray4d) + end if + end if + realArray4d(:,:,:,:) = real(singleArray4d(:,:,:,:),RKIND) + deallocate(singleArray4d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray4d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start5(:) = 1 + start5(5) = handle % frame_number + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, realArray4d) + else + start4(:) = 1 + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = field_cursor % fieldhandle % dims(4) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, realArray4d) + end if + end if + end if 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) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray5d(size(realArray5d,1),size(realArray5d,2),size(realArray5d,3),size(realArray5d,4),size(realArray5d,5))) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray5d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start6(:) = 1 + start6(6) = handle % frame_number + count6(1) = field_cursor % fieldhandle % dims(1) % dimsize + count6(2) = field_cursor % fieldhandle % dims(2) % dimsize + count6(3) = field_cursor % fieldhandle % dims(3) % dimsize + count6(4) = field_cursor % fieldhandle % dims(4) % dimsize + count6(5) = field_cursor % fieldhandle % dims(5) % dimsize + count6(6) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start6, count6, singleArray5d) + else + start5(:) = 1 + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = field_cursor % fieldhandle % dims(5) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, singleArray5d) + end if + end if + realArray5d(:,:,:,:,:) = real(singleArray5d(:,:,:,:,:),RKIND) + deallocate(singleArray5d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray5d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start6(:) = 1 + start6(6) = handle % frame_number + count6(1) = field_cursor % fieldhandle % dims(1) % dimsize + count6(2) = field_cursor % fieldhandle % dims(2) % dimsize + count6(3) = field_cursor % fieldhandle % dims(3) % dimsize + count6(4) = field_cursor % fieldhandle % dims(4) % dimsize + count6(5) = field_cursor % fieldhandle % dims(5) % dimsize + count6(6) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start6, count6, realArray5d) + else + start5(:) = 1 + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = field_cursor % fieldhandle % dims(5) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, realArray5d) + end if + end if + end if else if (present(intArray1d)) then ! write (0,*) ' value is int1' - call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - intArray1d, pio_ierr) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + intArray1d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start2(1) = 1 + start2(2) = handle % frame_number + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, intArray1d) + else + start1(:) = 1 + count1(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, intArray1d) + end if + end if else if (present(intArray2d)) then ! write (0,*) ' value is int2' - call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - intArray2d, pio_ierr) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + intArray2d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start3(:) = 1 + start3(3) = handle % frame_number + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, intArray2d) + else + start2(:) = 1 + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = field_cursor % fieldhandle % dims(2) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, intArray2d) + end if + end if else if (present(intArray3d)) then ! write (0,*) ' value is int3' - call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - intArray3d, pio_ierr) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + intArray3d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start4(:) = 1 + start4(4) = handle % frame_number + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, intArray3d) + else + start3(:) = 1 + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = field_cursor % fieldhandle % dims(3) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, intArray3d) + end if + end if else if (present(intArray4d)) then ! write (0,*) ' value is int4' - call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - intArray4d, pio_ierr) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + intArray4d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start5(:) = 1 + start5(5) = handle % frame_number + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = 1 + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, intArray4d) + else + start4(:) = 1 + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = field_cursor % fieldhandle % dims(4) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, intArray4d) + end if + end if end if ! write (0,*) 'Checking for error' @@ -1574,6 +2049,32 @@ subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr) end subroutine MPAS_io_get_var_char0d + logical function MPAS_io_would_clobber_records(handle, ierr) + + implicit none + + type (MPAS_IO_Handle_type), intent(inout) :: handle + integer, intent(out), optional :: ierr + + + if (present(ierr)) ierr = MPAS_IO_NOERR + + ! Sanity checks + if (.not. handle % initialized) then + if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE + MPAS_io_would_clobber_records = .false. + return + end if + + if (handle % frame_number <= handle % preexisting_records) then + MPAS_io_would_clobber_records = .true. + else + MPAS_io_would_clobber_records = .false. + end if + + end function MPAS_io_would_clobber_records + + subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArray2d, intArray3d, intArray4d, & realVal, realArray1d, realArray2d, realArray3d, realArray4d, realArray5d, & charVal, ierr) @@ -1601,8 +2102,23 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr integer, dimension(1) :: count1 integer, dimension(2) :: start2 integer, dimension(2) :: count2 + integer, dimension(3) :: start3 + integer, dimension(3) :: count3 + integer, dimension(4) :: start4 + integer, dimension(4) :: count4 + integer, dimension(5) :: start5 + integer, dimension(5) :: count5 + integer, dimension(6) :: start6 + integer, dimension(6) :: count6 type (fieldlist_type), pointer :: field_cursor + real (kind=R4KIND) :: singleVal + real (kind=R4KIND), dimension(:), allocatable :: singleArray1d + real (kind=R4KIND), dimension(:,:), allocatable :: singleArray2d + real (kind=R4KIND), dimension(:,:,:), allocatable :: singleArray3d + real (kind=R4KIND), dimension(:,:,:,:), allocatable :: singleArray4d + real (kind=R4KIND), dimension(:,:,:,:,:), allocatable :: singleArray5d + ! Sanity checks if (.not. handle % initialized) then if (present(ierr)) ierr = MPAS_IO_ERR_UNINIT_HANDLE @@ -1613,14 +2129,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr handle % data_mode = .true. pio_ierr = PIO_enddef(handle % pio_file) - if (pio_ierr /= PIO_noerr) then + ! If we are working with a preexisting file, we likely didn't define + ! new dimensions or variables, in which case PIO_enddef() will return + ! an error under harmless circumstances; so, don't return only for + ! pre-existing files. + if (pio_ierr /= PIO_noerr .and. (.not. handle % preexisting_file)) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if end if -! write(stderrUnit,*) 'Writing ', trim(fieldname) - +! write(stderrUnit,*) 'Writing ', trim(fieldname) ! ! Check whether the field has been defined @@ -1637,18 +2156,8 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr return end if - - ! - ! Check that we have a decomposition for this field - ! - if (.not.present(intVal) .and. .not.present(realVal) .and. .not.present(charVal)) then - if (.not. associated(field_cursor % fieldhandle % decomp)) then - if (present(ierr)) ierr = MPAS_IO_ERR_NO_DECOMP - return - end if - end if - if (field_cursor % fieldhandle % has_unlimited_dim) then + call PIO_setframe(field_cursor % fieldhandle % field_desc, handle % frame_number) start1(1) = handle % frame_number count1(1) = 1 @@ -1657,15 +2166,25 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr start2(2) = handle % frame_number count2(2) = 1 else if (handle % frame_number > 1) then - if(present(ierr)) ierr = MPAS_IO_NOERR + if (present(ierr)) ierr = MPAS_IO_NOERR return end if if (present(realVal)) then - if (field_cursor % fieldhandle % has_unlimited_dim) then - pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + singleVal = real(realVal,R4KIND) + if (field_cursor % fieldhandle % has_unlimited_dim) then + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, singleVal) + else + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, singleVal) + end if else - pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal) + if (field_cursor % fieldhandle % has_unlimited_dim) then + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal) + else + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal) + end if end if else if (present(intVal)) then if (field_cursor % fieldhandle % has_unlimited_dim) then @@ -1683,32 +2202,351 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, (/charVal/)) end if else if (present(realArray1d)) then - call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - realArray1d, pio_ierr) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray1d(size(realArray1d))) + singleArray1d(:) = real(realArray1d(:),R4KIND) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray1d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start2(1) = 1 + start2(2) = handle % frame_number + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, singleArray1d) + else + start1(1) = 1 + count1(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, singleArray1d) + end if + end if + deallocate(singleArray1d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray1d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start2(1) = 1 + start2(2) = handle % frame_number + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, realArray1d) + else + start1(1) = 1 + count1(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, realArray1d) + end if + end if + end if else if (present(realArray2d)) then - call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - realArray2d, pio_ierr) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray2d(size(realArray2d,1), size(realArray2d,2))) + singleArray2d(:,:) = real(realArray2d(:,:),R4KIND) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray2d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start3(1) = 1 + start3(2) = 1 + start3(3) = handle % frame_number + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, singleArray2d) + else + start2(:) = 1 + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = field_cursor % fieldhandle % dims(2) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, singleArray2d) + end if + end if + deallocate(singleArray2d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray2d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start3(1) = 1 + start3(2) = 1 + start3(3) = handle % frame_number + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, realArray2d) + else + start2(:) = 1 + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = field_cursor % fieldhandle % dims(2) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, realArray2d) + end if + end if + end if else if (present(realArray3d)) then - call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - realArray3d, pio_ierr) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray3d(size(realArray3d,1), size(realArray3d,2), size(realArray3d,3))) + singleArray3d(:,:,:) = real(realArray3d(:,:,:),R4KIND) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray3d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start4(1) = 1 + start4(2) = 1 + start4(3) = 1 + start4(4) = handle % frame_number + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, singleArray3d) + else + start3(:) = 1 + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = field_cursor % fieldhandle % dims(3) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, singleArray3d) + end if + end if + deallocate(singleArray3d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray3d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start4(1) = 1 + start4(2) = 1 + start4(3) = 1 + start4(4) = handle % frame_number + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, realArray3d) + else + start3(:) = 1 + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = field_cursor % fieldhandle % dims(3) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, realArray3d) + end if + end if + end if 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) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray4d(size(realArray4d,1), size(realArray4d,2), size(realArray4d,3), size(realArray4d,4))) + singleArray4d(:,:,:,:) = real(realArray4d(:,:,:,:),R4KIND) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray4d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start5(1) = 1 + start5(2) = 1 + start5(3) = 1 + start5(4) = 1 + start5(5) = handle % frame_number + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, singleArray4d) + else + start4(:) = 1 + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = field_cursor % fieldhandle % dims(4) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, singleArray4d) + end if + end if + deallocate(singleArray4d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray4d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start5(1) = 1 + start5(2) = 1 + start5(3) = 1 + start5(4) = 1 + start5(5) = handle % frame_number + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, realArray4d) + else + start4(:) = 1 + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = field_cursor % fieldhandle % dims(4) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, realArray4d) + end if + end if + end if 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) + if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & + (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + allocate(singleArray5d(size(realArray5d,1), size(realArray5d,2), size(realArray5d,3), size(realArray5d,4), size(realArray5d,5))) + singleArray5d(:,:,:,:,:) = real(realArray5d(:,:,:,:,:),R4KIND) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + singleArray5d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start6(1) = 1 + start6(2) = 1 + start6(3) = 1 + start6(4) = 1 + start6(5) = 1 + start6(6) = handle % frame_number + count6(1) = field_cursor % fieldhandle % dims(1) % dimsize + count6(2) = field_cursor % fieldhandle % dims(2) % dimsize + count6(3) = field_cursor % fieldhandle % dims(3) % dimsize + count6(4) = field_cursor % fieldhandle % dims(4) % dimsize + count6(5) = field_cursor % fieldhandle % dims(5) % dimsize + count6(6) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start6, count6, singleArray5d) + else + start5(:) = 1 + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = field_cursor % fieldhandle % dims(5) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, singleArray5d) + end if + end if + deallocate(singleArray5d) + else + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + realArray5d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start6(1) = 1 + start6(2) = 1 + start6(3) = 1 + start6(4) = 1 + start6(5) = 1 + start6(6) = handle % frame_number + count6(1) = field_cursor % fieldhandle % dims(1) % dimsize + count6(2) = field_cursor % fieldhandle % dims(2) % dimsize + count6(3) = field_cursor % fieldhandle % dims(3) % dimsize + count6(4) = field_cursor % fieldhandle % dims(4) % dimsize + count6(5) = field_cursor % fieldhandle % dims(5) % dimsize + count6(6) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start6, count6, realArray5d) + else + start5(:) = 1 + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = field_cursor % fieldhandle % dims(5) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, realArray5d) + end if + end if + end if 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) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + intArray1d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start2(1) = 1 + start2(2) = handle % frame_number + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, intArray1d) + else + start1(1) = 1 + count1(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, intArray1d) + end if + end if else if (present(intArray2d)) then - call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - intArray2d, pio_ierr) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + intArray2d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start3(1) = 1 + start3(2) = 1 + start3(3) = handle % frame_number + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, intArray2d) + else + start2(:) = 1 + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + count2(2) = field_cursor % fieldhandle % dims(2) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, intArray2d) + end if + end if else if (present(intArray3d)) then - call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - intArray3d, pio_ierr) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + intArray3d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start4(1) = 1 + start4(2) = 1 + start4(3) = 1 + start4(4) = handle % frame_number + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, intArray3d) + else + start3(:) = 1 + count3(1) = field_cursor % fieldhandle % dims(1) % dimsize + count3(2) = field_cursor % fieldhandle % dims(2) % dimsize + count3(3) = field_cursor % fieldhandle % dims(3) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, intArray3d) + end if + end if else if (present(intArray4d)) then - call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & - intArray4d, pio_ierr) + if (associated(field_cursor % fieldhandle % decomp)) then + call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & + intArray4d, pio_ierr) + else + if (field_cursor % fieldhandle % has_unlimited_dim) then + start5(1) = 1 + start5(2) = 1 + start5(3) = 1 + start5(4) = 1 + start5(5) = handle % frame_number + count5(1) = field_cursor % fieldhandle % dims(1) % dimsize + count5(2) = field_cursor % fieldhandle % dims(2) % dimsize + count5(3) = field_cursor % fieldhandle % dims(3) % dimsize + count5(4) = field_cursor % fieldhandle % dims(4) % dimsize + count5(5) = 1 + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, intArray4d) + else + start4(:) = 1 + count4(1) = field_cursor % fieldhandle % dims(1) % dimsize + count4(2) = field_cursor % fieldhandle % dims(2) % dimsize + count4(3) = field_cursor % fieldhandle % dims(3) % dimsize + count4(4) = field_cursor % fieldhandle % dims(4) % dimsize + pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, intArray4d) + end if + end if end if if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO @@ -3308,7 +4146,35 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, ierr) pio_ierr = PIO_put_att(handle % pio_file, varid, attName, trim(attValue)) if (pio_ierr /= PIO_noerr) then + if (present(ierr)) ierr = MPAS_IO_ERR_PIO + + ! + ! If we are working with a pre-existing file and the text attribute is larger than in the file, we need + ! to enter define mode before writing the attribute. Note the PIO_redef documentation: + ! 'Entering and leaving netcdf define mode causes a file sync operation to occur, + ! these operations can be very expensive in parallel systems.' + ! + if (handle % preexisting_file .and. .not. handle % data_mode) then + pio_ierr = PIO_redef(handle % pio_file) + if (pio_ierr /= PIO_noerr) then + return + end if + + pio_ierr = PIO_put_att(handle % pio_file, varid, attName, trim(attValue)) + if (pio_ierr /= PIO_noerr) then + return + end if + + pio_ierr = PIO_enddef(handle % pio_file) + if (pio_ierr /= PIO_noerr) then + return + end if + + if (present(ierr)) ierr = MPAS_IO_NOERR + + end if + return end if @@ -3468,7 +4334,7 @@ subroutine MPAS_io_finalize(io_system, ierr) end do !write(stderrUnit,*) 'MGD PIO_finalize' - if(.not.present(io_system)) then + 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 @@ -3526,6 +4392,8 @@ subroutine MPAS_io_err_mesg(ierr, fatal) write(stderrUnit,*) 'MPAS IO Error: No unlimited dimension found in dataset' case (MPAS_IO_ERR_UNIMPLEMENTED) write(stderrUnit,*) 'MPAS IO Error: Unimplemented functionality' + case (MPAS_IO_ERR_WOULD_CLOBBER) + write(stderrUnit,*) 'MPAS IO Error: Would clobber existing file' case default write(stderrUnit,*) 'MPAS IO Error: Unrecognized error code...' end select diff --git a/src/framework/mpas_io_output.F b/src/framework/mpas_io_output.F deleted file mode 100644 index 11f6f9619c..0000000000 --- a/src/framework/mpas_io_output.F +++ /dev/null @@ -1,396 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -module mpas_io_output - - use mpas_grid_types - use mpas_dmpar - use mpas_sort - use mpas_configure - use mpas_io_streams - - integer, parameter :: OUTPUT = 1 - integer, parameter :: RESTART = 2 - integer, parameter :: SFC = 3 - - type io_output_object - character (len=StrKIND) :: filename - integer :: stream - - integer :: time - - type (MPAS_Stream_type) :: io_stream - end type io_output_object - - private :: mpas_insert_string_suffix - - contains - - subroutine mpas_output_state_init(output_obj, domain, stream, outputSuffix)!{{{ - - implicit none - - type (io_output_object), intent(inout) :: output_obj - type (domain_type), intent(in) :: domain - character (len=*) :: stream - character (len=*), optional :: outputSuffix - - character (len=StrKIND) :: tempfilename - - type (block_type), pointer :: block_ptr - - block_ptr => domain % blocklist - - if (trim(stream) == 'OUTPUT') then - if(present(outputSuffix)) then - call mpas_insert_string_suffix(config_output_name, outputSuffix, tempfilename) - else - tempfilename = config_output_name - end if - output_obj % filename = trim(tempfilename) - output_obj % stream = OUTPUT - else if (trim(stream) == 'RESTART') then - if(present(outputSuffix)) then - call mpas_insert_string_suffix(config_restart_name, outputSuffix, tempfilename) - open(22,file=trim(config_restart_timestamp_name),form='formatted',status='replace') - write(22,*) outputSuffix - close(22) - else - tempfilename = config_restart_name - end if - output_obj % filename = trim(tempfilename) - output_obj % stream = RESTART - else if (trim(stream) == 'SFC') then - ! Keep filename as whatever was set by the user - output_obj % stream = SFC - end if - - ! For now, we assume that a domain consists only of one block, - ! although in future, work needs to be done to write model state - ! from many distributed blocks - call mpas_io_output_init(domain, output_obj, domain % dminfo, & - block_ptr % mesh & - ) - - end subroutine mpas_output_state_init!}}} - - subroutine mpas_insert_string_suffix(stream, suffix, filename)!{{{ - - implicit none - - character (len=*), intent(in) :: stream - character (len=*), intent(in) :: suffix - character (len=*), intent(out) :: filename - integer :: length, i - - filename = trim(stream) // '.' // trim(suffix) - - length = len_trim(stream) - do i=length-1,1,-1 - if(stream(i:i) == '.') then - filename = trim(stream(:i)) // trim(suffix) // trim(stream(i:)) - exit - end if - end do - - do i=1,len_trim(filename) - if (filename(i:i) == ':') filename(i:i) = '.' - end do - - end subroutine mpas_insert_string_suffix!}}} - - subroutine mpas_output_state_for_domain(output_obj, domain, itime)!{{{ - - implicit none - - type (io_output_object), intent(inout) :: output_obj - type (domain_type), intent(inout) :: domain - integer, intent(in) :: itime - - type(block_type), pointer :: block_ptr - - integer :: nCells, nEdges, nVertices, vertexDegree - integer :: maxEdges, maxEdges2, nEdgesSolve, nCellsSolve, nVerticesSolve - integer :: ierr - integer :: i, j - type (field2dInteger), pointer :: cellsOnCell_save, edgesOnCell_save, verticesOnCell_save, & - cellsOnEdge_save, verticesOnEdge_save, edgesOnEdge_save, & - cellsOnVertex_save, edgesOnVertex_save - - type (field2dInteger), pointer :: cellsOnCell_ptr, edgesOnCell_ptr, verticesOnCell_ptr, & - cellsOnEdge_ptr, verticesOnEdge_ptr, edgesOnEdge_ptr, & - cellsOnVertex_ptr, edgesOnVertex_ptr - - output_obj % time = itime - - ! - ! Convert connectivity information from local to global indices - ! Needs to be done block by block - ! - ! Also, backup local indices to be copied back into blocks after output is complete. - ! - allocate(cellsOnCell_save) - allocate(edgesOnCell_save) - allocate(verticesOnCell_save) - allocate(cellsOnEdge_save) - allocate(verticesOnEdge_save) - allocate(edgesOnEdge_save) - allocate(cellsOnVertex_save) - allocate(edgesOnVertex_save) - - cellsOnCell_ptr => cellsOnCell_save - edgesOnCell_ptr => edgesOnCell_save - verticesOnCell_ptr => verticesOnCell_save - cellsOnEdge_ptr => cellsOnEdge_save - verticesOnEdge_ptr => verticesOnEdge_save - edgesOnEdge_ptr => edgesOnEdge_save - cellsOnVertex_ptr => cellsOnVertex_save - edgesOnVertex_ptr => edgesOnVertex_save - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - maxEdges = block_ptr % mesh % maxEdges - maxEdges2 = block_ptr % mesh % maxEdges2 - vertexDegree = block_ptr % mesh % vertexDegree - nCells = block_ptr % mesh % nCells - nEdges = block_ptr % mesh % nEdges - nVertices = block_ptr % mesh % nVertices - nCellsSolve = block_ptr % mesh % nCellsSolve - nEdgesSolve = block_ptr % mesh % nEdgesSolve - nVerticesSolve = block_ptr % mesh % nVerticesSolve - - nullify(cellsOncell_ptr % ioinfo) - cellsOncell_ptr % array => block_ptr % mesh % cellsOncell % array - allocate(block_ptr % mesh % cellsOnCell % array(maxEdges, nCells+1)) - - nullify(edgesOnCell_ptr % ioinfo) - edgesOnCell_ptr % array => block_ptr % mesh % edgesOnCell % array - allocate(block_ptr % mesh % edgesOnCell % array(maxEdges, nCells+1)) - - nullify(verticesOnCell_ptr % ioinfo) - verticesOnCell_ptr % array => block_ptr % mesh % verticesOnCell % array - allocate(block_ptr % mesh % verticesOnCell % array(maxEdges, nCells+1)) - - nullify(cellsOnEdge_ptr % ioinfo) - cellsOnEdge_ptr % array => block_ptr % mesh % cellsOnEdge % array - allocate(block_ptr % mesh % cellsOnEdge % array(2, nEdges+1)) - - nullify(verticesOnEdge_ptr % ioinfo) - verticesOnEdge_ptr % array => block_ptr % mesh % verticesOnEdge % array - allocate(block_ptr % mesh % verticesOnEdge % array(2, nEdges+1)) - - nullify(edgesOnEdge_ptr % ioinfo) - edgesOnEdge_ptr % array => block_ptr % mesh % edgesOnEdge % array - allocate(block_ptr % mesh % edgesOnEdge % array(maxEdges2, nEdges+1)) - - nullify(cellsOnVertex_ptr % ioinfo) - cellsOnVertex_ptr % array => block_ptr % mesh % cellsOnVertex % array - allocate(block_ptr % mesh % cellsOnVertex % array(vertexDegree, nVertices+1)) - - nullify(edgesOnVertex_ptr % ioinfo) - edgesOnVertex_ptr % array => block_ptr % mesh % edgesOnVertex % array - allocate(block_ptr % mesh % edgesOnVertex % array(vertexDegree, nVertices+1)) - - do i = 1, nCellsSolve - do j = 1, block_ptr % mesh % nEdgesOnCell % array(i) - block_ptr % mesh % cellsOnCell % array(j, i) = block_ptr % mesh % indexToCellID % array(cellsOnCell_ptr % array(j, i)) - block_ptr % mesh % edgesOnCell % array(j, i) = block_ptr % mesh % indexToEdgeID % array(edgesOnCell_ptr % array(j, i)) - block_ptr % mesh % verticesOnCell % array(j, i) = block_ptr % mesh % indexToVertexID % array(verticesOnCell_ptr % array(j, i)) - end do - - block_ptr % mesh % cellsOnCell % array(block_ptr % mesh % nEdgesOnCell % array(i) + 1:maxEdges, i) = nCells+1 - block_ptr % mesh % edgesOnCell % array(block_ptr % mesh % nEdgesOnCell % array(i) + 1:maxEdges, i) = nEdges+1 - block_ptr % mesh % verticesOnCell % array(block_ptr % mesh % nEdgesOnCell % array(i) + 1:maxEdges, i) = nVertices+1 - end do - - do i = 1, nEdgesSolve - block_ptr % mesh % cellsOnEdge % array(1, i) = block_ptr % mesh % indexToCellID % array(cellsOnEdge_ptr % array(1, i)) - block_ptr % mesh % cellsOnEdge % array(2, i) = block_ptr % mesh % indexToCellID % array(cellsOnEdge_ptr % array(2, i)) - - block_ptr % mesh % verticesOnedge % array(1, i) = block_ptr % mesh % indexToVertexID % array(verticesOnEdge_ptr % array(1,i)) - block_ptr % mesh % verticesOnedge % array(2, i) = block_ptr % mesh % indexToVertexID % array(verticesOnEdge_ptr % array(2,i)) - - do j = 1, block_ptr % mesh % nEdgesOnEdge % array(i) - block_ptr % mesh % edgesOnEdge % array(j, i) = block_ptr % mesh % indexToEdgeID % array(edgesOnEdge_ptr % array(j, i)) - end do - - block_ptr % mesh % edgesOnEdge % array(block_ptr % mesh % nEdgesOnEdge % array(i)+1:maxEdges2, i) = nEdges+1 - end do - - do i = 1, nVerticesSolve - do j = 1, vertexDegree - block_ptr % mesh % cellsOnVertex % array(j, i) = block_ptr % mesh % indexToCellID % array(cellsOnVertex_ptr % array(j, i)) - block_ptr % mesh % edgesOnVertex % array(j, i) = block_ptr % mesh % indexToEdgeID % array(edgesOnVertex_ptr % array(j, i)) - end do - end do - - block_ptr => block_ptr % next - if(associated(block_ptr)) then - allocate(cellsOnCell_ptr % next) - allocate(edgesOnCell_ptr % next) - allocate(verticesOnCell_ptr % next) - allocate(cellsOnEdge_ptr % next) - allocate(verticesOnEdge_ptr % next) - allocate(edgesOnEdge_ptr % next) - allocate(cellsOnVertex_ptr % next) - allocate(edgesOnVertex_ptr % next) - - cellsOnCell_ptr => cellsOnCell_ptr % next - edgesOnCell_ptr => edgesOnCell_ptr % next - verticesOnCell_ptr => verticesOnCell_ptr % next - cellsOnEdge_ptr => cellsOnEdge_ptr % next - verticesOnEdge_ptr => verticesOnEdge_ptr % next - edgesOnEdge_ptr => edgesOnEdge_ptr % next - cellsOnVertex_ptr => cellsOnVertex_ptr % next - edgesOnVertex_ptr => edgesOnVertex_ptr % next - end if - - nullify(cellsOnCell_ptr % next) - nullify(edgesOnCell_ptr % next) - nullify(verticesOnCell_ptr % next) - nullify(cellsOnEdge_ptr % next) - nullify(verticesOnEdge_ptr % next) - nullify(edgesOnEdge_ptr % next) - nullify(cellsOnVertex_ptr % next) - nullify(edgesOnVertex_ptr % next) - end do - - ! Write output file - call MPAS_writeStream(output_obj % io_stream, output_obj % time, ierr) - - ! Converge indices back to local indices, and deallocate all temporary arrays. - cellsOnCell_ptr => cellsOnCell_save - edgesOnCell_ptr => edgesOnCell_save - verticesOnCell_ptr => verticesOnCell_save - cellsOnEdge_ptr => cellsOnEdge_save - verticesOnEdge_ptr => verticesOnEdge_save - edgesOnEdge_ptr => edgesOnEdge_save - cellsOnVertex_ptr => cellsOnVertex_save - edgesOnVertex_ptr => edgesOnVertex_save - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - - deallocate(block_ptr % mesh % cellsOnCell % array) - deallocate(block_ptr % mesh % edgesOnCell % array) - deallocate(block_ptr % mesh % verticesOnCell % array) - deallocate(block_ptr % mesh % cellsOnEdge % array) - deallocate(block_ptr % mesh % verticesOnEdge % array) - deallocate(block_ptr % mesh % edgesOnEdge % array) - deallocate(block_ptr % mesh % cellsOnVertex % array) - deallocate(block_ptr % mesh % edgesOnVertex % array) - - block_ptr % mesh % cellsOncell % array => cellsOnCell_ptr % array - block_ptr % mesh % edgesOnCell % array => edgesOnCell_ptr % array - block_ptr % mesh % verticesOnCell % array => verticesOnCell_ptr % array - block_ptr % mesh % cellsOnEdge % array => cellsOnEdge_ptr % array - block_ptr % mesh % verticesOnEdge % array => verticesOnEdge_ptr % array - block_ptr % mesh % edgesOnEdge % array => edgesOnEdge_ptr % array - block_ptr % mesh % cellsOnVertex % array => cellsOnVertex_ptr % array - block_ptr % mesh % edgesOnVertex % array => edgesOnVertex_ptr % array - - nullify(cellsOnCell_ptr % array) - nullify(edgesOnCell_ptr % array) - nullify(verticesOnCell_ptr % array) - nullify(cellsOnEdge_ptr % array) - nullify(verticesOnEdge_ptr % array) - nullify(edgesOnEdge_ptr % array) - nullify(cellsOnVertex_ptr % array) - nullify(edgesOnVertex_ptr % array) - - block_ptr => block_ptr % next - cellsOnCell_ptr => cellsOnCell_ptr % next - edgesOnCell_ptr => edgesOnCell_ptr % next - verticesOnCell_ptr => verticesOnCell_ptr % next - cellsOnEdge_ptr => cellsOnEdge_ptr % next - verticesOnEdge_ptr => verticesOnEdge_ptr % next - edgesOnEdge_ptr => edgesOnEdge_ptr % next - cellsOnVertex_ptr => cellsOnVertex_ptr % next - edgesOnVertex_ptr => edgesOnVertex_ptr % next - end do - - call mpas_deallocate_field(cellsOnCell_save) - call mpas_deallocate_field(edgesOnCell_save) - call mpas_deallocate_field(verticesOnCell_save) - call mpas_deallocate_field(cellsOnEdge_save) - call mpas_deallocate_field(verticesOnEdge_save) - call mpas_deallocate_field(edgesOnEdge_save) - call mpas_deallocate_field(cellsOnVertex_save) - call mpas_deallocate_field(edgesOnVertex_save) - - - - end subroutine mpas_output_state_for_domain!}}} - - subroutine mpas_output_state_finalize(output_obj, dminfo)!{{{ - - implicit none - - type (io_output_object), intent(inout) :: output_obj - type (dm_info), intent(in) :: dminfo - - call mpas_io_output_finalize(output_obj, dminfo) - - end subroutine mpas_output_state_finalize!}}} - - subroutine mpas_io_output_init( domain, output_obj, &!{{{ - dminfo, & - mesh & - ) - - implicit none - - type (domain_type), intent(in) :: domain - type (io_output_object), intent(inout) :: output_obj - type (dm_info), intent(in) :: dminfo - type (mesh_type), intent(in) :: mesh - - integer :: nferr, ierr - integer, dimension(10) :: dimlist - character (len=StrKIND*4) :: runCmd - - if(len(trim(domain % history)) > 0) then - write(runCmd,'(a,a,i0,a,a,a)') trim(domain % history),' mpirun -n ',domain % dminfo % nProcs, ' ', trim(domain % coreName), '_model; ' - else - write(runCmd,'(a,i0,a,a,a)') 'mpirun -n ',domain % dminfo % nProcs, ' ', trim(domain % coreName), '_model; ' - end if - - call MPAS_createStream(output_obj % io_stream, trim(output_obj % filename), MPAS_IO_PNETCDF, MPAS_IO_WRITE, 1, nferr) - -#include "add_output_fields.inc" - - if (mesh % on_a_sphere) then - call MPAS_writeStreamAtt(output_obj % io_stream, 'on_a_sphere', 'YES ', nferr) - else - call MPAS_writeStreamAtt(output_obj % io_stream, 'on_a_sphere', 'NO ', nferr) - end if - call MPAS_writeStreamAtt(output_obj % io_stream, 'sphere_radius', mesh % sphere_radius, nferr) - call MPAS_writeStreamAtt(output_obj % io_stream, 'model_name', domain % modelName, nferr) - call MPAS_writeStreamAtt(output_obj % io_stream, 'core_name', domain % coreName, nferr) - call MPAS_writeStreamAtt(output_obj % io_stream, 'model_version', domain % modelVersion, nferr) - call MPAS_writeStreamAtt(output_obj % io_stream, 'history', runCmd, nferr) - call MPAS_writeStreamAtt(output_obj % io_stream, 'source', 'MPAS', nferr) - call MPAS_writeStreamAtt(output_obj % io_stream, 'Conventions', 'MPAS', nferr) - -#include "add_output_atts.inc" - - end subroutine mpas_io_output_init!}}} - - subroutine mpas_io_output_finalize(output_obj, dminfo)!{{{ - - implicit none - - type (io_output_object), intent(inout) :: output_obj - type (dm_info), intent(in) :: dminfo - - integer :: nferr - - call MPAS_closeStream(output_obj % io_stream, nferr) - - end subroutine mpas_io_output_finalize!}}} - -end module mpas_io_output diff --git a/src/framework/mpas_io_streams.F b/src/framework/mpas_io_streams.F index da0a37d96e..e496eb084d 100644 --- a/src/framework/mpas_io_streams.F +++ b/src/framework/mpas_io_streams.F @@ -7,6 +7,9 @@ ! module mpas_io_streams +#define COMMA , +#define STREAM_DEBUG_WRITE(M) write(stderrUnit,*) M + #ifdef SINGLE_PRECISION #define REAL_IO_TYPE MPAS_IO_REAL #else @@ -15,6 +18,7 @@ module mpas_io_streams use mpas_attlist use mpas_grid_types + use mpas_kind_types, only : StrKIND use mpas_timekeeping use mpas_io use mpas_io_units @@ -44,7 +48,9 @@ module mpas_io_streams logical :: isInitialized = .false. integer :: ioFormat integer :: ioDirection - integer :: framesPerFile + integer :: defaultPrecision = MPAS_IO_NATIVE_PRECISION + logical :: clobberRecords = .false. + character(len=StrKIND) :: filename type (MPAS_IO_Handle_type) :: fileHandle type (att_list_type), pointer :: attList => null() type (field_list_type), pointer :: fieldList => null() @@ -65,6 +71,20 @@ module mpas_io_streams module procedure MPAS_streamAddField_0dChar end interface MPAS_streamAddField + interface MPAS_streamUpdateField + module procedure MPAS_streamUpdateField_0dInteger + module procedure MPAS_streamUpdateField_1dInteger + module procedure MPAS_streamUpdateField_2dInteger + module procedure MPAS_streamUpdateField_3dInteger + module procedure MPAS_streamUpdateField_0dReal + module procedure MPAS_streamUpdateField_1dReal + module procedure MPAS_streamUpdateField_2dReal + module procedure MPAS_streamUpdateField_3dReal + module procedure MPAS_streamUpdateField_4dReal + module procedure MPAS_streamUpdateField_5dReal + module procedure MPAS_streamUpdateField_0dChar + end interface MPAS_streamUpdateField + interface MPAS_readStreamAtt module procedure MPAS_readStreamAtt_0dInteger module procedure MPAS_readStreamAtt_1dInteger @@ -81,16 +101,21 @@ module mpas_io_streams module procedure MPAS_writeStreamAtt_text end interface MPAS_writeStreamAtt - integer, parameter :: MPAS_STREAM_EXACT_TIME = 100, & - MPAS_STREAM_NEAREST = 101, & - MPAS_STREAM_LATEST_BEFORE = 102, & - MPAS_STREAM_EARLIEST_AFTER = 103 + integer, parameter :: MPAS_STREAM_EXACT_TIME = 100, & + MPAS_STREAM_NEAREST = 101, & + MPAS_STREAM_LATEST_BEFORE = 102, & + MPAS_STREAM_EARLIEST_AFTER = 103, & + MPAS_STREAM_LATEST_STRICTLY_BEFORE = 104, & + MPAS_STREAM_EARLIEST_STRICTLY_AFTER = 105 ! Error codes integer, parameter :: MPAS_STREAM_NOERR = 0, & MPAS_STREAM_NOT_INITIALIZED = -1, & - MPAS_IO_ERR = -2 + MPAS_STREAM_FIELD_NOT_FOUND = -2, & + MPAS_STREAM_CLOBBER_FILE = -3, & + MPAS_STREAM_CLOBBER_RECORD = -4, & + MPAS_IO_ERR = -5 integer, parameter :: FIELD_0D_INT = 1, & FIELD_1D_INT = 2, & @@ -108,10 +133,11 @@ module mpas_io_streams private mergeArrays -contains + contains - subroutine MPAS_createStream(stream, fileName, ioFormat, ioDirection, framesPerFile, ierr) + subroutine MPAS_createStream(stream, fileName, ioFormat, ioDirection, precision, & + clobberRecords, clobberFiles, truncateFiles, ierr) implicit none @@ -119,14 +145,28 @@ subroutine MPAS_createStream(stream, fileName, ioFormat, ioDirection, framesPerF character (len=*), intent(in) :: fileName integer, intent(in) :: ioFormat integer, intent(in) :: ioDirection - integer, intent(in) :: framesPerFile + integer, intent(in), optional :: precision + logical, intent(in), optional :: clobberRecords + logical, intent(in), optional :: clobberFiles + logical, intent(in), optional :: truncateFiles integer, intent(out), optional :: ierr integer :: io_err if (present(ierr)) ierr = MPAS_STREAM_NOERR - stream % fileHandle = MPAS_io_open(fileName, ioDirection, ioFormat, io_err) + + stream % fileHandle = MPAS_io_open(fileName, ioDirection, ioFormat, clobber_file=clobberFiles, truncate_file=truncateFiles, & + ierr=io_err) + ! + ! Catch a few special errors + ! + if (io_err == MPAS_IO_ERR_WOULD_CLOBBER) then + if (present(ierr)) ierr = MPAS_STREAM_CLOBBER_FILE + return + end if + + ! General error call MPAS_io_err_mesg(io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR @@ -135,14 +175,20 @@ subroutine MPAS_createStream(stream, fileName, ioFormat, ioDirection, framesPerF stream % ioDirection = ioDirection stream % ioFormat = ioFormat - stream % framesPerFile = framesPerFile + stream % filename = fileName + if (present(clobberRecords)) then + stream % clobberRecords = clobberRecords + else + stream % clobberRecords = .false. + end if + if (present(precision)) stream % defaultPrecision = precision stream % isInitialized = .true. end subroutine MPAS_createStream - integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, ierr) + integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, maxRecords, ierr) implicit none @@ -150,6 +196,7 @@ integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, ier character (len=*), intent(in) :: seekTime integer, intent(in) :: seekPosition character (len=*), intent(out) :: actualTime + integer, intent(out), optional :: maxRecords integer, intent(out), optional :: ierr integer :: io_err @@ -168,6 +215,7 @@ integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, ier if (present(ierr)) ierr = MPAS_STREAM_NOERR MPAS_seekStream = 0 + if (present(maxRecords)) maxRecords = 0 ! ! Sanity checks @@ -183,11 +231,14 @@ integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, ier return end if + if (present(maxRecords)) maxRecords = timeDim + !write(stderrUnit,*) 'Found ', timeDim, ' times in file' call MPAS_io_inq_var(stream % fileHandle, 'xtime', ierr=io_err) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR + if (present(maxRecords)) maxRecords = 0 return end if @@ -240,6 +291,22 @@ integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, ier MPAS_seekStream = i end if end if + else if (seekPosition == MPAS_STREAM_LATEST_STRICTLY_BEFORE) then + if (sliceTime < startTime) then + timeDiff = abs(sliceTime - startTime) + if (timeDiff < minTimeDiff) then + minTimeDiff = timeDiff + MPAS_seekStream = i + end if + end if + else if (seekPosition == MPAS_STREAM_EARLIEST_STRICTLY_AFTER) then + if (sliceTime > startTime) then + timeDiff = abs(sliceTime - startTime) + if (timeDiff < minTimeDiff) then + minTimeDiff = timeDiff + MPAS_seekStream = i + end if + end if else write(stderrUnit,*) 'Error in MPAS_seekStream: unrecognized seekPosition' deallocate(xtimes) @@ -261,6 +328,52 @@ integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, ier end function MPAS_seekStream + subroutine MPAS_streamTime(stream, frame, frameValidTime, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + integer, intent(in) :: frame + character (len=*), intent(out) :: frameValidTime + integer, intent(out), optional :: ierr + + integer :: io_err + integer :: timeDim + + +! write(stderrUnit,*) 'Called MPAS_streamTime' + + ! + ! Initialize output arguments + ! + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_IO_ERR + return + end if + + call MPAS_io_inq_var(stream % fileHandle, 'xtime', ierr=io_err) + if (io_err /= MPAS_IO_NOERR) then + if (present(ierr)) ierr = MPAS_IO_ERR + return + end if + +!write(stderrUnit,*) 'Found xtime variable' + + call MPAS_io_set_frame(stream % fileHandle, frame, io_err) + call MPAS_io_get_var(stream % fileHandle, 'xtime', frameValidTime, io_err) + if (io_err /= MPAS_IO_NOERR) then + if (present(ierr)) ierr = MPAS_IO_ERR + return + end if + + end subroutine MPAS_streamTime + + subroutine MPAS_streamAddField_0dInteger(stream, field, ierr) implicit none @@ -311,7 +424,7 @@ subroutine MPAS_streamAddField_0dInteger(stream, field, ierr) totalDimSize = 0 call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_INT, dimNames, dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, ierr=io_err) deallocate(indices) deallocate(dimSizes) @@ -364,6 +477,10 @@ subroutine MPAS_streamAddField_1dInteger(stream, field, ierr) logical :: any_success logical, dimension(:), pointer :: isAvailable + type (mpas_pool_type), pointer :: meshPool + integer, dimension(:), pointer :: indexArray + integer, pointer :: indexDimension + if (present(ierr)) ierr = MPAS_STREAM_NOERR ! @@ -398,7 +515,7 @@ subroutine MPAS_streamAddField_1dInteger(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_INT, dimNames0, & dimSizes0, field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then isAvailable(i) = .true. any_success = .true. @@ -407,7 +524,7 @@ subroutine MPAS_streamAddField_1dInteger(stream, field, ierr) else nullify(isAvailable) call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_INT, field % dimNames, field % dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then any_success = .true. end if @@ -467,6 +584,11 @@ subroutine MPAS_streamAddField_2dInteger(stream, field, ierr) logical :: any_success logical, dimension(:), pointer :: isAvailable + type (mpas_pool_type), pointer :: meshPool + integer, dimension(:), pointer :: indexArray + integer, pointer :: indexDimension + + if (present(ierr)) ierr = MPAS_STREAM_NOERR ! @@ -501,7 +623,7 @@ subroutine MPAS_streamAddField_2dInteger(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_INT, field % dimNames(2:ndims), & field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then isAvailable(i) = .true. any_success = .true. @@ -510,7 +632,7 @@ subroutine MPAS_streamAddField_2dInteger(stream, field, ierr) else nullify(isAvailable) call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_INT, field % dimNames, field % dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then any_success = .true. end if @@ -570,6 +692,11 @@ subroutine MPAS_streamAddField_3dInteger(stream, field, ierr) logical :: any_success logical, dimension(:), pointer :: isAvailable + type (mpas_pool_type), pointer :: meshPool + integer, dimension(:), pointer :: indexArray + integer, pointer :: indexDimension + + if (present(ierr)) ierr = MPAS_STREAM_NOERR ! @@ -603,7 +730,7 @@ subroutine MPAS_streamAddField_3dInteger(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_INT, field % dimNames(2:ndims), & field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then isAvailable(i) = .true. any_success = .true. @@ -612,7 +739,7 @@ subroutine MPAS_streamAddField_3dInteger(stream, field, ierr) else nullify(isAvailable) call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_INT, field % dimNames, field % dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then any_success = .true. end if @@ -649,12 +776,13 @@ subroutine MPAS_streamAddField_3dInteger(stream, field, ierr) end subroutine MPAS_streamAddField_3dInteger - subroutine MPAS_streamAddField_0dReal(stream, field, ierr) + subroutine MPAS_streamAddField_0dReal(stream, field, precision, ierr) implicit none type (MPAS_Stream_type), intent(inout) :: stream type (field0DReal), intent(in), target :: field + integer, intent(in), optional :: precision integer, intent(out), optional :: ierr integer :: io_err @@ -669,6 +797,7 @@ subroutine MPAS_streamAddField_0dReal(stream, field, ierr) integer, dimension(:), pointer :: dimSizes type (field_list_type), pointer :: field_list_cursor type (field_list_type), pointer :: new_field_list_node + integer :: local_precision if (present(ierr)) ierr = MPAS_STREAM_NOERR @@ -680,6 +809,13 @@ subroutine MPAS_streamAddField_0dReal(stream, field, ierr) return end if + + if (present(precision)) then + local_precision = precision + else + local_precision = stream % defaultPrecision + end if + !write(stderrUnit,*) '... Adding field '//trim(field % fieldName)//' to stream' ndims = 0 @@ -699,7 +835,7 @@ subroutine MPAS_streamAddField_0dReal(stream, field, ierr) totalDimSize = 0 call MPAS_streamAddField_generic(stream, trim(field % fieldName), REAL_IO_TYPE , dimNames, dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, precision=local_precision, ierr=io_err) deallocate(indices) deallocate(dimSizes) @@ -727,12 +863,13 @@ subroutine MPAS_streamAddField_0dReal(stream, field, ierr) end subroutine MPAS_streamAddField_0dReal - subroutine MPAS_streamAddField_1dReal(stream, field, ierr) + subroutine MPAS_streamAddField_1dReal(stream, field, precision, ierr) implicit none type (MPAS_Stream_type), intent(inout) :: stream type (field1DReal), intent(in), target :: field + integer, intent(in), optional :: precision integer, intent(out), optional :: ierr integer :: io_err @@ -751,6 +888,12 @@ subroutine MPAS_streamAddField_1dReal(stream, field, ierr) type (field_list_type), pointer :: new_field_list_node logical :: any_success logical, dimension(:), pointer :: isAvailable + integer :: local_precision + + type (mpas_pool_type), pointer :: meshPool + integer, dimension(:), pointer :: indexArray + integer, pointer :: indexDimension + if (present(ierr)) ierr = MPAS_STREAM_NOERR @@ -762,7 +905,14 @@ subroutine MPAS_streamAddField_1dReal(stream, field, ierr) return end if - if(.not. field % isPersistent .or. .not. field % isActive) then + + if (present(precision)) then + local_precision = precision + else + local_precision = stream % defaultPrecision + end if + + if (.not. field % isPersistent .or. .not. field % isActive) then return end if @@ -786,7 +936,7 @@ subroutine MPAS_streamAddField_1dReal(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), REAL_IO_TYPE , dimNames0, & dimSizes0, field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then isAvailable(i) = .true. any_success = .true. @@ -795,7 +945,7 @@ subroutine MPAS_streamAddField_1dReal(stream, field, ierr) else nullify(isAvailable) call MPAS_streamAddField_generic(stream, trim(field % fieldName), REAL_IO_TYPE , field % dimNames, field % dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then any_success = .true. end if @@ -832,12 +982,13 @@ subroutine MPAS_streamAddField_1dReal(stream, field, ierr) end subroutine MPAS_streamAddField_1dReal - subroutine MPAS_streamAddField_2dReal(stream, field, ierr) + subroutine MPAS_streamAddField_2dReal(stream, field, precision, ierr) implicit none type (MPAS_Stream_type), intent(inout) :: stream type (field2DReal), intent(in), target :: field + integer, intent(in), optional :: precision integer, intent(out), optional :: ierr integer :: io_err @@ -854,6 +1005,12 @@ subroutine MPAS_streamAddField_2dReal(stream, field, ierr) type (field_list_type), pointer :: new_field_list_node logical :: any_success logical, dimension(:), pointer :: isAvailable + integer :: local_precision + + type (mpas_pool_type), pointer :: meshPool + integer, dimension(:), pointer :: indexArray + integer, pointer :: indexDimension + if (present(ierr)) ierr = MPAS_STREAM_NOERR @@ -865,7 +1022,14 @@ subroutine MPAS_streamAddField_2dReal(stream, field, ierr) return end if - if(.not. field % isPersistent .or. .not. field % isActive) then + + if (present(precision)) then + local_precision = precision + else + local_precision = stream % defaultPrecision + end if + + if (.not. field % isPersistent .or. .not. field % isActive) then return end if @@ -889,7 +1053,7 @@ subroutine MPAS_streamAddField_2dReal(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), REAL_IO_TYPE , field % dimNames(2:ndims), & field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then isAvailable(i) = .true. any_success = .true. @@ -898,7 +1062,7 @@ subroutine MPAS_streamAddField_2dReal(stream, field, ierr) else nullify(isAvailable) call MPAS_streamAddField_generic(stream, trim(field % fieldName), REAL_IO_TYPE , field % dimNames, field % dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then any_success = .true. end if @@ -935,12 +1099,13 @@ subroutine MPAS_streamAddField_2dReal(stream, field, ierr) end subroutine MPAS_streamAddField_2dReal - subroutine MPAS_streamAddField_3dReal(stream, field, ierr) + subroutine MPAS_streamAddField_3dReal(stream, field, precision, ierr) implicit none type (MPAS_Stream_type), intent(inout) :: stream type (field3DReal), intent(in), target :: field + integer, intent(in), optional :: precision integer, intent(out), optional :: ierr integer :: io_err @@ -957,6 +1122,12 @@ subroutine MPAS_streamAddField_3dReal(stream, field, ierr) type (field_list_type), pointer :: new_field_list_node logical :: any_success logical, dimension(:), pointer :: isAvailable + integer :: local_precision + + type (mpas_pool_type), pointer :: meshPool + integer, dimension(:), pointer :: indexArray + integer, pointer :: indexDimension + if (present(ierr)) ierr = MPAS_STREAM_NOERR @@ -968,7 +1139,14 @@ subroutine MPAS_streamAddField_3dReal(stream, field, ierr) return end if - if(.not. field % isPersistent .or. .not. field % isActive) then + + if (present(precision)) then + local_precision = precision + else + local_precision = stream % defaultPrecision + end if + + if (.not. field % isPersistent .or. .not. field % isActive) then return end if @@ -993,7 +1171,7 @@ subroutine MPAS_streamAddField_3dReal(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), REAL_IO_TYPE , field % dimNames(2:ndims), & field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then isAvailable(i) = .true. any_success = .true. @@ -1002,7 +1180,7 @@ subroutine MPAS_streamAddField_3dReal(stream, field, ierr) else nullify(isAvailable) call MPAS_streamAddField_generic(stream, trim(field % fieldName), REAL_IO_TYPE , field % dimNames, field % dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then any_success = .true. end if @@ -1040,12 +1218,13 @@ subroutine MPAS_streamAddField_3dReal(stream, field, ierr) end subroutine MPAS_streamAddField_3dReal - subroutine MPAS_streamAddField_4dReal(stream, field, ierr) + subroutine MPAS_streamAddField_4dReal(stream, field, precision, ierr) implicit none type (MPAS_Stream_type), intent(inout) :: stream type (field4DReal), intent(in), target :: field + integer, intent(in), optional :: precision integer, intent(out), optional :: ierr integer :: io_err @@ -1062,6 +1241,12 @@ subroutine MPAS_streamAddField_4dReal(stream, field, ierr) type (field_list_type), pointer :: new_field_list_node logical :: any_success logical, dimension(:), pointer :: isAvailable + integer :: local_precision + + type (mpas_pool_type), pointer :: meshPool + integer, dimension(:), pointer :: indexArray + integer, pointer :: indexDimension + if (present(ierr)) ierr = MPAS_STREAM_NOERR @@ -1073,7 +1258,14 @@ subroutine MPAS_streamAddField_4dReal(stream, field, ierr) return end if - if(.not. field % isPersistent .or. .not. field % isActive) then + + if (present(precision)) then + local_precision = precision + else + local_precision = stream % defaultPrecision + end if + + if (.not. field % isPersistent .or. .not. field % isActive) then return end if @@ -1098,7 +1290,7 @@ subroutine MPAS_streamAddField_4dReal(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), REAL_IO_TYPE , field % dimNames(2:ndims), & field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then isAvailable(i) = .true. any_success = .true. @@ -1107,7 +1299,7 @@ subroutine MPAS_streamAddField_4dReal(stream, field, ierr) else nullify(isAvailable) call MPAS_streamAddField_generic(stream, trim(field % fieldName), REAL_IO_TYPE , field % dimNames, field % dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then any_success = .true. end if @@ -1145,12 +1337,13 @@ subroutine MPAS_streamAddField_4dReal(stream, field, ierr) end subroutine MPAS_streamAddField_4dReal - subroutine MPAS_streamAddField_5dReal(stream, field, ierr) + subroutine MPAS_streamAddField_5dReal(stream, field, precision, ierr) implicit none type (MPAS_Stream_type), intent(inout) :: stream type (field5DReal), intent(in), target :: field + integer, intent(in), optional :: precision integer, intent(out), optional :: ierr integer :: io_err @@ -1167,6 +1360,12 @@ subroutine MPAS_streamAddField_5dReal(stream, field, ierr) type (field_list_type), pointer :: new_field_list_node logical :: any_success logical, dimension(:), pointer :: isAvailable + integer :: local_precision + + type (mpas_pool_type), pointer :: meshPool + integer, dimension(:), pointer :: indexArray + integer, pointer :: indexDimension + if (present(ierr)) ierr = MPAS_STREAM_NOERR @@ -1178,7 +1377,14 @@ subroutine MPAS_streamAddField_5dReal(stream, field, ierr) return end if - if(.not. field % isPersistent .or. .not. field % isActive) then + + if (present(precision)) then + local_precision = precision + else + local_precision = stream % defaultPrecision + end if + + if (.not. field % isPersistent .or. .not. field % isActive) then return end if @@ -1203,7 +1409,7 @@ subroutine MPAS_streamAddField_5dReal(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), REAL_IO_TYPE , field % dimNames(2:ndims), & field % dimSizes(2:ndims), field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then isAvailable(i) = .true. any_success = .true. @@ -1212,7 +1418,7 @@ subroutine MPAS_streamAddField_5dReal(stream, field, ierr) else nullify(isAvailable) call MPAS_streamAddField_generic(stream, trim(field % fieldName), REAL_IO_TYPE , field % dimNames, field % dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, precision=local_precision, ierr=io_err) if (io_err == MPAS_STREAM_NOERR) then any_success = .true. end if @@ -1306,11 +1512,11 @@ subroutine MPAS_streamAddField_0dChar(stream, field, ierr) do i=1,size(field % constituentNames) call MPAS_streamAddField_generic(stream, trim(field % constituentNames(i)), MPAS_IO_CHAR, dimNames(1:1), & dimSizes, field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, & - indices, io_err) + indices, ierr=io_err) end do else call MPAS_streamAddField_generic(stream, trim(field % fieldName), MPAS_IO_CHAR, dimNames(1:1), dimSizes, & - field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, io_err) + field % hasTimeDimension, isDecomposed, totalDimSize, globalDimSize, indices, ierr=io_err) end if deallocate(indices) @@ -1345,7 +1551,7 @@ end subroutine MPAS_streamAddField_0dChar subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, dimSizes, hasTimeDimension, isDecomposed, & - totalDimSize, globalDimSize, indices, ierr) + totalDimSize, globalDimSize, indices, precision, ierr) implicit none @@ -1359,6 +1565,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d integer, intent(in) :: totalDimSize integer, intent(in) :: globalDimSize integer, dimension(:), intent(in) :: indices + integer, intent(in), optional :: precision integer, intent(out), optional :: ierr integer :: io_err @@ -1445,7 +1652,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d ! !write(stderrUnit,*) '... defining var to low-level interface with ndims ', ndims - call MPAS_io_def_var(stream % fileHandle, trim(fieldName), fieldType, dimNamesLocal(1:ndims), io_err) + call MPAS_io_def_var(stream % fileHandle, trim(fieldName), fieldType, dimNamesLocal(1:ndims), precision=precision, ierr=io_err) call MPAS_io_err_mesg(io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR @@ -1518,7 +1725,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d ! ! Set variable indices ! - if (ndims > 0) then + if (ndims > 0 .and. isDecomposed) then call MPAS_io_set_var_indices(stream % fileHandle, trim(fieldName), indices, io_err) call MPAS_io_err_mesg(io_err, .false.) if (io_err /= MPAS_IO_NOERR) then @@ -1547,6 +1754,532 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d end subroutine MPAS_streamAddField_generic + subroutine MPAS_streamUpdateField_0dInteger(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field0DInteger), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 0d integer field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_0D_INT) then + if (field_cursor % int0dField % fieldname == field % fieldname) then + STREAM_DEBUG_WRITE( '... found 0d integer named '//trim(field_cursor % int0dField % fieldname) ) + field_cursor % int0dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 0d integer field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_0dInteger + + + subroutine MPAS_streamUpdateField_1dInteger(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field1DInteger), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 1d integer field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_1D_INT) then + if (field_cursor % int1dField % fieldname == field % fieldname .and. & + field_cursor % int1dField % dimSizes(1) == field % dimSizes(1) .and. & + field_cursor % int1dField % dimNames(1) == field % dimNames(1)) then + STREAM_DEBUG_WRITE( '... found 1d integer named '//trim(field_cursor % int1dField % fieldname) ) + field_cursor % int1dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 1d integer field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_1dInteger + + + subroutine MPAS_streamUpdateField_2dInteger(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field2DInteger), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 2d integer field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_2D_INT) then + if (field_cursor % int2dField % fieldname == field % fieldname .and. & + field_cursor % int2dField % dimSizes(1) == field % dimSizes(1) .and. & + field_cursor % int2dField % dimSizes(2) == field % dimSizes(2) .and. & + field_cursor % int2dField % dimNames(1) == field % dimNames(1) .and. & + field_cursor % int2dField % dimNames(2) == field % dimNames(2)) then + STREAM_DEBUG_WRITE( '... found 2d integer named '//trim(field_cursor % int2dField % fieldname) ) + field_cursor % int2dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 2d integer field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_2dInteger + + + subroutine MPAS_streamUpdateField_3dInteger(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field3DInteger), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 3d integer field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_3D_INT) then + if (field_cursor % int3dField % fieldname == field % fieldname .and. & + field_cursor % int3dField % dimSizes(1) == field % dimSizes(1) .and. & + field_cursor % int3dField % dimSizes(2) == field % dimSizes(2) .and. & + field_cursor % int3dField % dimSizes(3) == field % dimSizes(3) .and. & + field_cursor % int3dField % dimNames(1) == field % dimNames(1) .and. & + field_cursor % int3dField % dimNames(2) == field % dimNames(2) .and. & + field_cursor % int3dField % dimNames(3) == field % dimNames(3)) then + STREAM_DEBUG_WRITE( '... found 3d integer named '//trim(field_cursor % int3dField % fieldname) ) + field_cursor % int3dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 3d integer field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_3dInteger + + + subroutine MPAS_streamUpdateField_0dReal(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field0DReal), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 0d real field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_0D_REAL) then + if (field_cursor % real0dField % fieldname == field % fieldname) then + STREAM_DEBUG_WRITE( '... found 0d real named '//trim(field_cursor % real0dField % fieldname) ) + field_cursor % real0dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 0d real field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_0dReal + + + subroutine MPAS_streamUpdateField_1dReal(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field1DReal), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 1d real field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_1D_REAL) then + if (field_cursor % real1dField % fieldname == field % fieldname .and. & + field_cursor % real1dField % dimSizes(1) == field % dimSizes(1) .and. & + field_cursor % real1dField % dimNames(1) == field % dimNames(1)) then + STREAM_DEBUG_WRITE( '... found 1d real named '//trim(field_cursor % real1dField % fieldname) ) + field_cursor % real1dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 1d real field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_1dReal + + + subroutine MPAS_streamUpdateField_2dReal(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field2DReal), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 2d real field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_2D_REAL) then + if (field_cursor % real2dField % fieldname == field % fieldname .and. & + field_cursor % real2dField % dimSizes(1) == field % dimSizes(1) .and. & + field_cursor % real2dField % dimSizes(2) == field % dimSizes(2) .and. & + field_cursor % real2dField % dimNames(1) == field % dimNames(1) .and. & + field_cursor % real2dField % dimNames(2) == field % dimNames(2)) then + STREAM_DEBUG_WRITE( '... found 2d real named '//trim(field_cursor % real2dField % fieldname) ) + field_cursor % real2dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 2d real field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_2dReal + + + subroutine MPAS_streamUpdateField_3dReal(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field3DReal), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 3d real field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_3D_REAL) then + if (field_cursor % real3dField % fieldname == field % fieldname .and. & + field_cursor % real3dField % dimSizes(1) == field % dimSizes(1) .and. & + field_cursor % real3dField % dimSizes(2) == field % dimSizes(2) .and. & + field_cursor % real3dField % dimSizes(3) == field % dimSizes(3) .and. & + field_cursor % real3dField % dimNames(1) == field % dimNames(1) .and. & + field_cursor % real3dField % dimNames(2) == field % dimNames(2) .and. & + field_cursor % real3dField % dimNames(3) == field % dimNames(3)) then + STREAM_DEBUG_WRITE( '... found 3d real named '//trim(field_cursor % real3dField % fieldname) ) + field_cursor % real3dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 3d real field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_3dReal + + + subroutine MPAS_streamUpdateField_4dReal(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field4DReal), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 4d real field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_4D_REAL) then + if (field_cursor % real4dField % fieldname == field % fieldname .and. & + field_cursor % real4dField % dimSizes(1) == field % dimSizes(1) .and. & + field_cursor % real4dField % dimSizes(2) == field % dimSizes(2) .and. & + field_cursor % real4dField % dimSizes(3) == field % dimSizes(3) .and. & + field_cursor % real4dField % dimSizes(4) == field % dimSizes(4) .and. & + field_cursor % real4dField % dimNames(1) == field % dimNames(1) .and. & + field_cursor % real4dField % dimNames(2) == field % dimNames(2) .and. & + field_cursor % real4dField % dimNames(3) == field % dimNames(3) .and. & + field_cursor % real4dField % dimNames(4) == field % dimNames(4)) then + STREAM_DEBUG_WRITE( '... found 4d real named '//trim(field_cursor % real4dField % fieldname) ) + field_cursor % real4dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 4d real field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_4dReal + + + subroutine MPAS_streamUpdateField_5dReal(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field5DReal), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 5d real field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_5D_REAL) then + if (field_cursor % real5dField % fieldname == field % fieldname .and. & + field_cursor % real5dField % dimSizes(1) == field % dimSizes(1) .and. & + field_cursor % real5dField % dimSizes(2) == field % dimSizes(2) .and. & + field_cursor % real5dField % dimSizes(3) == field % dimSizes(3) .and. & + field_cursor % real5dField % dimSizes(4) == field % dimSizes(4) .and. & + field_cursor % real5dField % dimSizes(5) == field % dimSizes(5) .and. & + field_cursor % real5dField % dimNames(1) == field % dimNames(1) .and. & + field_cursor % real5dField % dimNames(2) == field % dimNames(2) .and. & + field_cursor % real5dField % dimNames(3) == field % dimNames(3) .and. & + field_cursor % real5dField % dimNames(4) == field % dimNames(4) .and. & + field_cursor % real5dField % dimNames(5) == field % dimNames(5)) then + STREAM_DEBUG_WRITE( '... found 5d real named '//trim(field_cursor % real5dField % fieldname) ) + field_cursor % real5dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 5d real field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_5dReal + + + subroutine MPAS_streamUpdateField_0dChar(stream, field, ierr) + + implicit none + + type (MPAS_Stream_type), intent(inout) :: stream + type (field0DChar), intent(in), target :: field + integer, intent(out), optional :: ierr + + type (field_list_type), pointer :: field_cursor + + + if (present(ierr)) ierr = MPAS_STREAM_NOERR + + ! + ! Sanity checks + ! + if (.not. stream % isInitialized) then + if (present(ierr)) ierr = MPAS_STREAM_NOT_INITIALIZED + return + end if + + STREAM_DEBUG_WRITE( '... Updating 0d char field '//trim(field % fieldName)//' in stream' ) + + field_cursor => stream % fieldList + do while (associated(field_cursor)) + if (field_cursor % field_type == FIELD_0D_CHAR) then + if (field_cursor % char0dField % fieldname == field % fieldname) then + STREAM_DEBUG_WRITE( '... found 0d char named '//trim(field_cursor % char0dField % fieldname) ) + field_cursor % char0dField => field + exit + end if + end if + field_cursor => field_cursor % next + end do + if (.not. associated(field_cursor)) then + STREAM_DEBUG_WRITE( '... 0d char field '//trim(field % fieldname)//' not found in stream' ) + if (present(ierr)) ierr = MPAS_STREAM_FIELD_NOT_FOUND + end if + + STREAM_DEBUG_WRITE( '... done updating field' ) + + end subroutine MPAS_streamUpdateField_0dChar + + subroutine MPAS_readStream(stream, frame, ierr) implicit none @@ -1558,7 +2291,7 @@ subroutine MPAS_readStream(stream, frame, ierr) integer :: io_err integer :: i, j integer :: ncons - integer :: ownedSize + integer, pointer :: ownedSize type (field0dInteger), pointer :: field_0dint_ptr type (field1dInteger), pointer :: field_1dint_ptr type (field2dInteger), pointer :: field_2dint_ptr @@ -1666,11 +2399,11 @@ subroutine MPAS_readStream(stream, frame, ierr) i = 1 do while (associated(field_1dint_ptr)) if (trim(field_1dint_ptr % dimNames(1)) == 'nCells') then - ownedSize = field_1dint_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_1dint_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_1dint_ptr % dimNames(1)) == 'nEdges') then - ownedSize = field_1dint_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_1dint_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_1dint_ptr % dimNames(1)) == 'nVertices') then - ownedSize = field_1dint_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_1dint_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_1dint_ptr % dimSizes(1) end if @@ -1744,11 +2477,11 @@ subroutine MPAS_readStream(stream, frame, ierr) i = 1 do while (associated(field_2dint_ptr)) if (trim(field_2dint_ptr % dimNames(2)) == 'nCells') then - ownedSize = field_2dint_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_2dint_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_2dint_ptr % dimNames(2)) == 'nEdges') then - ownedSize = field_2dint_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_2dint_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_2dint_ptr % dimNames(2)) == 'nVertices') then - ownedSize = field_2dint_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_2dint_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_2dint_ptr % dimSizes(2) end if @@ -1826,11 +2559,11 @@ subroutine MPAS_readStream(stream, frame, ierr) i = 1 do while (associated(field_3dint_ptr)) if (trim(field_3dint_ptr % dimNames(3)) == 'nCells') then - ownedSize = field_3dint_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_3dint_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_3dint_ptr % dimNames(3)) == 'nEdges') then - ownedSize = field_3dint_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_3dint_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_3dint_ptr % dimNames(3)) == 'nVertices') then - ownedSize = field_3dint_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_3dint_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_3dint_ptr % dimSizes(3) end if @@ -1927,11 +2660,11 @@ subroutine MPAS_readStream(stream, frame, ierr) do while (associated(field_1dreal_ptr)) if (trim(field_1dreal_ptr % dimNames(1)) == 'nCells') then - ownedSize = field_1dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_1dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_1dreal_ptr % dimNames(1)) == 'nEdges') then - ownedSize = field_1dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_1dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_1dreal_ptr % dimNames(1)) == 'nVertices') then - ownedSize = field_1dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_1dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_1dreal_ptr % dimSizes(1) end if @@ -2005,11 +2738,11 @@ subroutine MPAS_readStream(stream, frame, ierr) i = 1 do while (associated(field_2dreal_ptr)) if (trim(field_2dreal_ptr % dimNames(2)) == 'nCells') then - ownedSize = field_2dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_2dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_2dreal_ptr % dimNames(2)) == 'nEdges') then - ownedSize = field_2dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_2dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_2dreal_ptr % dimNames(2)) == 'nVertices') then - ownedSize = field_2dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_2dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_2dreal_ptr % dimSizes(2) end if @@ -2090,11 +2823,11 @@ subroutine MPAS_readStream(stream, frame, ierr) i = 1 do while (associated(field_3dreal_ptr)) if (trim(field_3dreal_ptr % dimNames(3)) == 'nCells') then - ownedSize = field_3dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_3dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_3dreal_ptr % dimNames(3)) == 'nEdges') then - ownedSize = field_3dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_3dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_3dreal_ptr % dimNames(3)) == 'nVertices') then - ownedSize = field_3dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_3dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_3dreal_ptr % dimSizes(3) end if @@ -2177,11 +2910,11 @@ subroutine MPAS_readStream(stream, frame, ierr) i = 1 do while (associated(field_4dreal_ptr)) if (trim(field_4dreal_ptr % dimNames(4)) == 'nCells') then - ownedSize = field_4dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_4dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_4dreal_ptr % dimNames(4)) == 'nEdges') then - ownedSize = field_4dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_4dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_4dreal_ptr % dimNames(4)) == 'nVertices') then - ownedSize = field_4dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_4dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_4dreal_ptr % dimSizes(4) end if @@ -2267,11 +3000,11 @@ subroutine MPAS_readStream(stream, frame, ierr) i = 1 do while (associated(field_5dreal_ptr)) if (trim(field_5dreal_ptr % dimNames(5)) == 'nCells') then - ownedSize = field_5dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_5dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_5dreal_ptr % dimNames(5)) == 'nEdges') then - ownedSize = field_5dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_5dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_5dreal_ptr % dimNames(5)) == 'nVertices') then - ownedSize = field_5dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_5dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_5dreal_ptr % dimSizes(5) end if @@ -2356,7 +3089,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) integer :: io_err integer :: i, j integer :: ncons - integer :: ownedSize + integer, pointer :: ownedSize type (field0dInteger), pointer :: field_0dint_ptr type (field1dInteger), pointer :: field_1dint_ptr type (field2dInteger), pointer :: field_2dint_ptr @@ -2401,6 +3134,19 @@ subroutine MPAS_writeStream(stream, frame, ierr) return end if + ! + ! Check whether we will clobber any records + ! + if (MPAS_io_would_clobber_records(stream % fileHandle, io_err)) then + if (.not. stream % clobberRecords) then + if (present(ierr)) ierr = MPAS_STREAM_CLOBBER_RECORD + return + else + write(stderrUnit,'(a,i4,a)') 'MPAS I/O: Overwriting existing record ', frame, & + ' in output file '//trim(stream % filename) + end if + end if + ! ! Loop over fields in the stream ! @@ -2437,11 +3183,11 @@ subroutine MPAS_writeStream(stream, frame, ierr) i = 1 do while (associated(field_1dint_ptr)) if (trim(field_1dint_ptr % dimNames(1)) == 'nCells') then - ownedSize = field_1dint_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_1dint_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_1dint_ptr % dimNames(1)) == 'nEdges') then - ownedSize = field_1dint_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_1dint_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_1dint_ptr % dimNames(1)) == 'nVertices') then - ownedSize = field_1dint_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_1dint_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_1dint_ptr % dimSizes(1) end if @@ -2494,11 +3240,11 @@ subroutine MPAS_writeStream(stream, frame, ierr) i = 1 do while (associated(field_2dint_ptr)) if (trim(field_2dint_ptr % dimNames(2)) == 'nCells') then - ownedSize = field_2dint_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_2dint_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_2dint_ptr % dimNames(2)) == 'nEdges') then - ownedSize = field_2dint_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_2dint_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_2dint_ptr % dimNames(2)) == 'nVertices') then - ownedSize = field_2dint_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_2dint_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_2dint_ptr % dimSizes(2) end if @@ -2554,11 +3300,11 @@ subroutine MPAS_writeStream(stream, frame, ierr) i = 1 do while (associated(field_3dint_ptr)) if (trim(field_3dint_ptr % dimNames(3)) == 'nCells') then - ownedSize = field_3dint_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_3dint_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_3dint_ptr % dimNames(3)) == 'nEdges') then - ownedSize = field_3dint_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_3dint_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_3dint_ptr % dimNames(3)) == 'nVertices') then - ownedSize = field_3dint_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_3dint_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_3dint_ptr % dimSizes(3) end if @@ -2624,11 +3370,11 @@ subroutine MPAS_writeStream(stream, frame, ierr) i = 1 do while (associated(field_1dreal_ptr)) if (trim(field_1dreal_ptr % dimNames(1)) == 'nCells') then - ownedSize = field_1dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_1dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_1dreal_ptr % dimNames(1)) == 'nEdges') then - ownedSize = field_1dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_1dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_1dreal_ptr % dimNames(1)) == 'nVertices') then - ownedSize = field_1dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_1dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_1dreal_ptr % dimSizes(1) end if @@ -2681,11 +3427,11 @@ subroutine MPAS_writeStream(stream, frame, ierr) i = 1 do while (associated(field_2dreal_ptr)) if (trim(field_2dreal_ptr % dimNames(2)) == 'nCells') then - ownedSize = field_2dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_2dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_2dreal_ptr % dimNames(2)) == 'nEdges') then - ownedSize = field_2dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_2dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_2dreal_ptr % dimNames(2)) == 'nVertices') then - ownedSize = field_2dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_2dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_2dreal_ptr % dimSizes(2) end if @@ -2741,11 +3487,11 @@ subroutine MPAS_writeStream(stream, frame, ierr) i = 1 do while (associated(field_3dreal_ptr)) if (trim(field_3dreal_ptr % dimNames(3)) == 'nCells') then - ownedSize = field_3dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_3dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_3dreal_ptr % dimNames(3)) == 'nEdges') then - ownedSize = field_3dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_3dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_3dreal_ptr % dimNames(3)) == 'nVertices') then - ownedSize = field_3dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_3dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_3dreal_ptr % dimSizes(3) end if @@ -2803,11 +3549,11 @@ subroutine MPAS_writeStream(stream, frame, ierr) i = 1 do while (associated(field_4dreal_ptr)) if (trim(field_4dreal_ptr % dimNames(4)) == 'nCells') then - ownedSize = field_4dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_4dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_4dreal_ptr % dimNames(4)) == 'nEdges') then - ownedSize = field_4dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_4dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_4dreal_ptr % dimNames(4)) == 'nVertices') then - ownedSize = field_4dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_4dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_4dreal_ptr % dimSizes(4) end if @@ -2867,11 +3613,11 @@ subroutine MPAS_writeStream(stream, frame, ierr) i = 1 do while (associated(field_5dreal_ptr)) if (trim(field_5dreal_ptr % dimNames(5)) == 'nCells') then - ownedSize = field_5dreal_ptr % block % mesh % nCellsSolve + call mpas_pool_get_dimension(field_5dreal_ptr % block % dimensions, 'nCellsSolve', ownedSize) else if (trim(field_5dreal_ptr % dimNames(5)) == 'nEdges') then - ownedSize = field_5dreal_ptr % block % mesh % nEdgesSolve + call mpas_pool_get_dimension(field_5dreal_ptr % block % dimensions, 'nEdgesSolve', ownedSize) else if (trim(field_5dreal_ptr % dimNames(5)) == 'nVertices') then - ownedSize = field_5dreal_ptr % block % mesh % nVerticesSolve + call mpas_pool_get_dimension(field_5dreal_ptr % block % dimensions, 'nVerticesSolve', ownedSize) else ownedSize = field_5dreal_ptr % dimSizes(5) end if diff --git a/src/framework/mpas_kind_types.F b/src/framework/mpas_kind_types.F index 058481e3bd..18fce2df59 100644 --- a/src/framework/mpas_kind_types.F +++ b/src/framework/mpas_kind_types.F @@ -19,13 +19,17 @@ module mpas_kind_types + integer, parameter :: R4KIND = selected_real_kind(6) #ifdef SINGLE_PRECISION integer, parameter :: RKIND = selected_real_kind(6) #else integer, parameter :: RKIND = selected_real_kind(12) #endif + integer, parameter :: I8KIND = selected_int_kind(18) + integer, parameter :: StrKIND = 512 + integer, parameter :: ShortStrKIND = 32 contains diff --git a/src/framework/mpas_packages.F b/src/framework/mpas_packages.F index 1303e11955..e629710a42 100644 --- a/src/framework/mpas_packages.F +++ b/src/framework/mpas_packages.F @@ -17,8 +17,6 @@ !----------------------------------------------------------------------- module mpas_packages -#include "define_packages.inc" - contains subroutine mpas_packages_dummy() diff --git a/src/framework/mpas_stream_list.F b/src/framework/mpas_stream_list.F new file mode 100644 index 0000000000..c656daedcf --- /dev/null +++ b/src/framework/mpas_stream_list.F @@ -0,0 +1,361 @@ +module mpas_stream_list + +#define COMMA , +#define LIST_DEBUG_WRITE(M) ! write(stderrUnit,*) M +#define LIST_WARN_WRITE(M) write(stderrUnit,*) 'WARNING: '//M +#define LIST_ERROR_WRITE(M) write(stderrUnit,*) 'ERROR: '//M + + use mpas_kind_types, only : StrKIND + use mpas_io_units, only : stderrUnit + use mpas_grid_types, only : mpas_pool_type + use mpas_io_streams, only : MPAS_Stream_type + use mpas_io, only : MPAS_IO_NATIVE_PRECISION + use mpas_timekeeping, only : MPAS_Time_type, MPAS_TimeInterval_type + + + integer, parameter :: MPAS_STREAM_LIST_NOERR = 0, & + MPAS_STREAM_LIST_DUPLICATE = 1, & + MPAS_STREAM_LIST_NOT_FOUND = 2 + + + type MPAS_stream_list_type + + ! Used by list head + integer :: nItems = 0 + type (MPAS_stream_list_type), pointer :: head => null() + + ! Used by streams + integer :: direction + logical :: valid = .false. + logical :: immutable = .false. + logical :: active_stream = .true. + character(len=StrKIND) :: filename + character(len=StrKIND) :: filename_template + character(len=StrKIND) :: filename_interval + type (MPAS_Stream_type), pointer :: stream => null() + integer :: timeLevel = 0 + integer :: nRecords + integer :: precision = MPAS_IO_NATIVE_PRECISION + integer :: clobber_mode + type (MPAS_TimeInterval_type), pointer :: recordInterval => null() + type (MPAS_stream_list_type), pointer :: alarmList_in => null() + type (MPAS_stream_list_type), pointer :: alarmList_out => null() + type (mpas_pool_type), pointer :: att_pool => null() + type (mpas_pool_type), pointer :: field_pool => null() + type (mpas_pool_type), pointer :: pkg_pool => null() + type (MPAS_Time_type), pointer :: referenceTime => null() + + ! Used by alarms + type (MPAS_stream_list_type), pointer :: streamList => null() + + ! Used by streams and alarms + character(len=StrKIND) :: name + type (MPAS_stream_list_type), pointer :: xref => null() + type (MPAS_stream_list_type), pointer :: next => null() + + end type MPAS_stream_list_type + + + contains + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_list_create + ! + !> \brief Initialize a new MPAS stream list. + !> \author Michael Duda, Doug Jacobsen + !> \date 08/06/2014 + !> \details + !> Instantiates and initializes a stream_list type, to store all active streams. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_list_create(list, ierr) !{{{ + + implicit none + + type (MPAS_stream_list_type), pointer :: list + integer, intent(out), optional :: ierr + + + LIST_DEBUG_WRITE(' -- Called MPAS_stream_list_create()') + + if (present(ierr)) ierr = MPAS_STREAM_LIST_NOERR + + allocate(list) + + list % nItems = 0 + nullify(list % head) + + end subroutine MPAS_stream_list_create !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_list_destroy + ! + !> \brief Free all memory associated with an MPAS stream list. + !> \author Michael Duda, Doug Jacobsen + !> \date 08/06/2014 + !> \details + !> Destroys a stream list type, freeing all memory that was created as + !> part of the list. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_list_destroy(list, ierr) !{{{ + + implicit none + + type (MPAS_stream_list_type), pointer:: list + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: node + + + LIST_DEBUG_WRITE(' -- Called MPAS_stream_list_destroy()') + + if (present(ierr)) ierr = MPAS_STREAM_LIST_NOERR + + if (.not. associated(list)) return + + if (list % nItems == 0) then + deallocate(list) + return + end if + + node => list % head + do while (associated(node)) + list % head => list % head % next + deallocate(node) + node => list % head + end do + + deallocate(list) + + end subroutine MPAS_stream_list_destroy !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_list_insert + ! + !> \brief Add a stream to a stream list + !> \author Michael Duda, Doug Jacobsen + !> \date 08/06/2014 + !> \details + !> Adds a stream to the list of streams, first makes sure the stream doesn't exist in the stream list. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_list_insert(list, stream, ierr) !{{{ + + implicit none + + type (MPAS_stream_list_type), intent(inout) :: list + type (MPAS_stream_list_type), pointer :: stream + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: node + + + LIST_DEBUG_WRITE(' -- Called MPAS_stream_list_insert()') + + if (present(ierr)) ierr = MPAS_STREAM_LIST_NOERR + + nullify(stream % next) + + if (.not. associated(list % head)) then + list % head => stream + else + node => list % head + do while (associated(node % next)) + if (node % name == stream % name) then + if (present(ierr)) ierr = MPAS_STREAM_LIST_DUPLICATE + LIST_ERROR_WRITE('Found duplicate item '//trim(stream % name)//' in list.') + return + end if + node => node % next + end do + node % next => stream + end if + + list % nItems = list % nItems + 1 + + end subroutine MPAS_stream_list_insert !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_list_remove + ! + !> \brief Remove a stream from a stream list + !> \author Michael Duda, Doug Jacobsen + !> \date 08/06/2014 + !> \details + !> Removes a stream from the list of streams. Exits if the stream doesn't exist. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_list_remove(list, streamName, stream, ierr) !{{{ + + implicit none + + type (MPAS_stream_list_type), intent(inout) :: list + character (len=*), intent(in) :: streamName + type (MPAS_stream_list_type), pointer :: stream + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: node, nodePrev + + + LIST_DEBUG_WRITE(' -- Called MPAS_stream_list_remove()') + + if (present(ierr)) ierr = MPAS_STREAM_LIST_NOERR + + ! Return if no streams exist in stream list + if ( list % nItems == 0 ) then + if (present(ierr)) ierr = MPAS_STREAM_LIST_NOT_FOUND + LIST_ERROR_WRITE('Item '//trim(streamName)//' not found in list.') + nullify(stream) + return + end if + + ! Check the head of the stream list + node => list % head + if (associated(node)) then + if (node % name == streamName) then + list % head => node % next + stream => node + list % nItems = list % nItems - 1 + return + end if + end if + + ! Loop through all streams until we find the one with StreamName + nodePrev => node + node => node % next + do while (associated(node)) + if (node % name == streamName) then + nodePrev % next => node % next + stream => node + list % nItems = list % nItems - 1 + return + end if + + nodePrev => node + node => node % next + end do + + ! If the routine hasn't returned yet, the stream was not found. Return an error. + if (present(ierr)) ierr = MPAS_STREAM_LIST_NOT_FOUND + LIST_ERROR_WRITE('Item '//trim(streamName)//' not found in list.') + nullify(stream) + + end subroutine MPAS_stream_list_remove !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_list_query + ! + !> \brief Get a stream from a stream list + !> \author Michael Duda, Doug Jacobsen + !> \date 08/06/2014 + !> \details + !> Searches through a stream list, and returns a pointer for the stream with a matching name. + ! + !----------------------------------------------------------------------- + logical function MPAS_stream_list_query(list, streamName, stream, ierr) result(found) !{{{ + + implicit none + + type (MPAS_stream_list_type), intent(in) :: list + character (len=*), intent(in) :: streamName + type (MPAS_stream_list_type), pointer :: stream + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: node + + + LIST_DEBUG_WRITE(' -- Called MPAS_stream_list_query()') + + if (present(ierr)) ierr = MPAS_STREAM_LIST_NOERR + found = .false. + + ! Return if no streams exist in stream list + if ( list % nItems == 0 ) then + LIST_DEBUG_WRITE(' -- Item '//trim(streamName)//' not found in list.') + nullify(stream) + return + end if + + node => list % head + do while (associated(node)) + if (node % name == streamName) then + found = .true. + stream => node + return + end if + node => node % next + end do + + LIST_DEBUG_WRITE(' -- Item '//trim(streamName)//' not found in list.') + nullify(stream) + + end function MPAS_stream_list_query !}}} + + + !----------------------------------------------------------------------- + ! routine printlist + ! + !> \brief Prints the contents of a list. + !> \author Michael Duda + !> \date 25 August 2014 + !> \details + !> Traverses a list, printing the 'name' component from each node. + ! + !----------------------------------------------------------------------- + subroutine printlist(list)!{{{ + + implicit none + + type (MPAS_stream_list_type), intent(in) :: list + + type (MPAS_stream_list_type), pointer :: node + integer :: i + + i = 1 + write(stderrUnit,*) '----------------------------' + write(stderrUnit,*) 'List contains:' + node => list % head + do while (associated(node)) + write(stderrUnit,'(a,i3,a)') ' ', i, ') '//trim(node % name) + i = i + 1 + node => node % next + end do + write(stderrUnit,*) '----------------------------' + + end subroutine printlist!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_list_length + ! + !> \brief Returns the length of a stream list + !> \author Michael Duda + !> \date 25 August 2014 + !> \details + !> Returns the number of items stored in a stream list. + ! + !----------------------------------------------------------------------- + integer function MPAS_stream_list_length(list, ierr) result(nItems) !{{{ + + implicit none + + type (MPAS_stream_list_type), intent(in) :: list + integer, intent(out), optional :: ierr + + + LIST_DEBUG_WRITE(' -- Called MPAS_stream_list_length()') + + if (present(ierr)) ierr = MPAS_STREAM_LIST_NOERR + + nItems = list % nItems + + end function MPAS_stream_list_length !}}} + + +end module mpas_stream_list diff --git a/src/framework/mpas_stream_manager.F b/src/framework/mpas_stream_manager.F new file mode 100644 index 0000000000..b79e1fa30e --- /dev/null +++ b/src/framework/mpas_stream_manager.F @@ -0,0 +1,4871 @@ +module mpas_stream_manager + +#define COMMA , +#define STREAM_DEBUG_WRITE(M) ! write(stderrUnit,*) M +#define STREAM_WARNING_WRITE(M) write(stderrUnit,*) 'WARNING: '//M +#define STREAM_ERROR_WRITE(M) write(stderrUnit,*) 'ERROR: '//M + + use mpas_kind_types + use mpas_grid_types + use mpas_timekeeping + use mpas_io_units + use mpas_io_streams + use mpas_stream_list + + + integer, public, parameter :: MPAS_STREAM_ERR_FATAL = 1000, & + MPAS_STREAM_ERR_WARN = 1001, & + MPAS_STREAM_ERR_SILENT = 1002 + + integer, public, parameter :: MPAS_STREAM_MGR_NOERR = 0, & + MPAS_STREAM_MGR_ERR_CLOBBER_FILE = -1, & + MPAS_STREAM_MGR_ERR_CLOBBER_REC = -2, & + MPAS_STREAM_MGR_ERROR = -3 + + integer, public, parameter :: MPAS_STREAM_INPUT = 1, & + MPAS_STREAM_OUTPUT = 2, & + MPAS_STREAM_INPUT_OUTPUT = 3, & + MPAS_STREAM_NONE = 4 + + integer, public, parameter :: MPAS_STREAM_PROPERTY_ACTIVE = 5, & + MPAS_STREAM_PROPERTY_IMMUTABLE = 6, & + MPAS_STREAM_PROPERTY_FILENAME = 7, & + MPAS_STREAM_PROPERTY_REF_TIME = 8, & + MPAS_STREAM_PROPERTY_RECORD_INTV = 9, & + MPAS_STREAM_PROPERTY_PRECISION = 10, & + MPAS_STREAM_PROPERTY_FILENAME_INTV = 11, & + MPAS_STREAM_PROPERTY_CLOBBER = 12 + + integer, public, parameter :: MPAS_STREAM_CLOBBER_NEVER = 100, & + MPAS_STREAM_CLOBBER_APPEND = 101, & + MPAS_STREAM_CLOBBER_TRUNCATE = 102, & + MPAS_STREAM_CLOBBER_OVERWRITE = 103 + + public :: MPAS_streamManager_type, & + MPAS_stream_mgr_init, & + MPAS_stream_mgr_finalize, & + MPAS_stream_mgr_create_stream, & + MPAS_stream_mgr_destroy_stream, & + MPAS_stream_mgr_get_clock, & + MPAS_stream_mgr_set_property, & + MPAS_stream_mgr_get_property, & + MPAS_stream_mgr_add_pkg, & + MPAS_stream_mgr_remove_pkg, & + MPAS_stream_mgr_add_pool, & + MPAS_stream_mgr_add_field, & + MPAS_stream_mgr_add_stream_fields, & + MPAS_stream_mgr_remove_field, & + MPAS_stream_mgr_add_alarm, & + MPAS_stream_mgr_remove_alarm, & + MPAS_stream_mgr_reset_alarms, & + MPAS_stream_mgr_ringing_alarms, & + MPAS_stream_mgr_add_att, & + MPAS_stream_mgr_write, & + MPAS_stream_mgr_read + + private + + type MPAS_streamManager_type + + integer :: numStreams = 0 + integer :: errorLevel + + type (MPAS_Clock_type), pointer :: streamClock + type (MPAS_Pool_type), pointer :: allFields + type (MPAS_Pool_type), pointer :: allPackages + type (MPAS_Pool_type), pointer :: allStructs + type (MPAS_Pool_type), pointer :: defaultAtts + + type (MPAS_stream_list_type), pointer :: streams + type (MPAS_stream_list_type), pointer :: alarms_in + type (MPAS_stream_list_type), pointer :: alarms_out + + end type MPAS_streamManager_type + + + interface MPAS_stream_mgr_set_property + module procedure MPAS_stream_mgr_set_property_int + module procedure MPAS_stream_mgr_set_property_char + module procedure MPAS_stream_mgr_set_property_logical + end interface + + + interface MPAS_stream_mgr_get_property + module procedure MPAS_stream_mgr_get_property_int + module procedure MPAS_stream_mgr_get_property_char + module procedure MPAS_stream_mgr_get_property_logical + end interface + + + interface MPAS_stream_mgr_add_att + module procedure MPAS_stream_mgr_add_att_int + module procedure MPAS_stream_mgr_add_att_real + module procedure MPAS_stream_mgr_add_att_char + module procedure MPAS_stream_mgr_add_att_logical + end interface + + + ! + ! Used for reindexing connectivity arrays during stream writes by the routines prewrite_reindex() and postwrite_reindex(). + ! Before a stream is written, we set the pointers here to be the heads of linked lists of locally-indexed connectivity fields. + ! After a stream is written, we reset the arrays for connectivity fields in the stream to these pointers. + ! + type (field2DInteger), pointer :: cellsOnCell_save + type (field2DInteger), pointer :: edgesOnCell_save + type (field2DInteger), pointer :: verticesOnCell_save + type (field2DInteger), pointer :: cellsOnEdge_save + type (field2DInteger), pointer :: verticesOnEdge_save + type (field2DInteger), pointer :: edgesOnEdge_save + type (field2DInteger), pointer :: cellsOnVertex_save + type (field2DInteger), pointer :: edgesOnVertex_save + + + contains + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_init + ! + !> \brief Initialize a new MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Instantiates and initializes a streamManager type with a timekeeping + !> clock and a pool from which fields may be drawn and added to streams. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_init(manager, clock, allFields, allPackages, allStructs, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_init' + + type (MPAS_streamManager_type), pointer :: manager + type (MPAS_Clock_type), pointer :: clock + type (MPAS_Pool_type), pointer :: allFields + type (MPAS_Pool_type), pointer :: allPackages + type (MPAS_Pool_type), pointer :: allStructs + integer, intent(out), optional :: ierr + + integer :: err_local + + call seed_random() + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_init()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + allocate(manager) + manager % allFields => allFields + manager % allPackages => allPackages + manager % allStructs => allStructs + manager % streamClock => clock + manager % numStreams = 0 + manager % errorLevel = MPAS_STREAM_ERR_SILENT + + ! + ! Set up linked list of streams + ! + call MPAS_stream_list_create(manager % streams, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while creating stream list') + return + end if + + ! + ! Set up linked list of input alarms + ! + call MPAS_stream_list_create(manager % alarms_in, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while creating input alarm list') + return + end if + + ! + ! Set up linked list of output alarms + ! + call MPAS_stream_list_create(manager % alarms_out, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while creating output alarm list') + return + end if + + ! + ! Create a pool to hold default global attributes that every stream will have + ! + call mpas_pool_create_pool(manager % defaultAtts) + + end subroutine MPAS_stream_mgr_init!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_finalize + ! + !> \brief Free all memory associated with an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Destroys a streamManager type, freeing all memory that was created as + !> part of the manager; the external clock and field pool associated with + !> the streamManager are unaffected. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_finalize(manager, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_finalize' + + type (MPAS_streamManager_type), pointer:: manager + integer, intent(out), optional :: ierr + + integer :: err_local + type (MPAS_stream_list_type), pointer :: stream_cursor + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_finalize()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Remove all streams + ! + stream_cursor => manager % streams % head + do while (associated(stream_cursor)) + STREAM_DEBUG_WRITE(' -- deleting stream '//trim(stream_cursor % name)) + call MPAS_stream_mgr_destroy_stream(manager, stream_cursor % name, ierr=err_local) + stream_cursor => manager % streams % head + end do + + ! + ! Free up list of streams + ! + call MPAS_stream_list_destroy(manager % streams, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while destroying stream list') + end if + + ! + ! Free up list of input alarms + ! + call MPAS_stream_list_destroy(manager % alarms_in, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while destroying input alarms list') + end if + + ! + ! Free up list of output alarms + ! + call MPAS_stream_list_destroy(manager % alarms_out, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while destroying output alarms list') + end if + + ! + ! Free up default attribute pool + ! + call mpas_pool_destroy_pool(manager % defaultAtts) + + deallocate(manager) + + end subroutine MPAS_stream_mgr_finalize!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_create_stream + ! + !> \brief Instantiate a new stream within an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Creates a new stream within the stream manager. The "direction" + !> argument may be either MPAS_STREAM_INPUT, MPAS_STREAM_OUTPUT, + !> MPAS_STREAM_INPUT_OUTPUT, or MPAS_STREAM_NONE. The "filename" argument + !> is the template of the filenames that are associated with the stream. + !> Knowing the interval between files, and + !> the filename template, a "referenceTime" argument must be provided to + !> specify the first timestamp appearing in any of the files associated with + !> the stream, thereby determining where the "file breaks" will occur between + !> timestamps. If no "referenceTime" is specified, the start time of the + !> clock associated with the stream handler will be used as the reference + !> time. Additionally, the interval between records in the file may be + !> specified using the optional "recordInterval" argument; if this argument + !> is not supplied, the stream manager will assume that this interval is + !> equal to the shortest period of any periodic alarm attached to the stream. + !> The optional argument 'realPrecision' specifies the precision of + !> real-valued fields in the files associated with the stream; this + !> argument may take on values MPAS_IO_SINGLE_PRECISION, + !> MPAS_IO_DOUBLE_PRECISION, or MPAS_IO_NATIVE_PRECISION; if this argument is + !> not supplied, native precision is assumed. + !> Note: Setting the precision of real fields is only supported at present + !> for converting double-precision to single-precision on output; input is + !> automatically converted from single- do double-precision if necessary. + !> The optional argument clobberMode determines how the stream manager will + !> deal with existing files; possible options include MPAS_STREAM_CLOBBER_NEVER, + !> MPAS_STREAM_CLOBBER_APPEND, MPAS_STREAM_CLOBBER_TRUNCATE, + !> and MPAS_STREAM_CLOBBER_OVERWRITE. The default behavior is to never modify + !> existing files (MPAS_STREAM_CLOBBER_NEVER). + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_create_stream(manager, streamID, direction, filename, & + filenameInterval, referenceTime, recordInterval, & + realPrecision, clobberMode, ierr) !{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_create_stream' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + integer, intent(in) :: direction + character (len=*), intent(in) :: filename + character (len=*), intent(in), optional :: filenameInterval + type (MPAS_Time_type), intent(in), optional :: referenceTime + type (MPAS_TimeInterval_type), intent(in), optional :: recordInterval + integer, intent(in), optional :: realPrecision + integer, intent(in), optional :: clobberMode + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: new_stream + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_create_stream() for '//trim(streamID)) + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Check that the stream does not already exist + ! + if (MPAS_stream_list_query(manager % streams, streamID, new_stream, ierr=err_local)) then + STREAM_DEBUG_WRITE('-- Stream '//trim(streamID)//' already exist in stream manager') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Allocate a stream node to store the new stream + ! + allocate(new_stream) + new_stream % name = streamID + new_stream % direction = direction + new_stream % valid = .false. +!TODO: ensure that filename does not contain ':' characters, which PNETCDF does not like... + new_stream % filename_template = filename + + ! Filename interval is 'none' by deault, but is set through the set_property routine. + if (present(filenameInterval)) then + new_stream % filename_interval = filenameInterval + else + new_stream % filename_interval = 'none' + end if + + new_stream % nRecords = 0 + if (present(clobberMode)) then + new_stream % clobber_mode = clobberMode + else + new_stream % clobber_mode = MPAS_STREAM_CLOBBER_NEVER + end if + allocate(new_stream % referenceTime) + if (present(referenceTime)) then + new_stream % referenceTime = referenceTime + else + new_stream % referenceTime = mpas_get_clock_time(manager % streamClock, MPAS_START_TIME) + end if + if (present(recordInterval)) then + allocate(new_stream % recordInterval) + new_stream % recordInterval = recordInterval + end if + if (present(realPrecision)) then + new_stream % precision = realPrecision + end if + call MPAS_stream_list_create(new_stream % alarmList_in, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while creating input alarm list') + deallocate(new_stream) + return + end if + call MPAS_stream_list_create(new_stream % alarmList_out, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while creating output alarm list') + deallocate(new_stream) + return + end if + call mpas_pool_create_pool(new_stream % att_pool) + call mpas_pool_clone_pool(manager % defaultAtts, new_stream % att_pool) + call mpas_pool_create_pool(new_stream % field_pool) + call mpas_pool_create_pool(new_stream % pkg_pool) + nullify(new_stream % next) + + + ! + ! Add stream to list + ! + call MPAS_stream_list_insert(manager % streams, new_stream, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while adding stream to list') + return + end if + + manager % numStreams = manager % numStreams + 1 + + end subroutine MPAS_stream_mgr_create_stream!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_destroy_stream + ! + !> \brief Free all memory associated with a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Destroy the stream, including freeing all memory explicitly associated with the stream. + !> This will not deallocate the memory associated with the fields in the stream. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_destroy_stream(manager, streamID, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_destroy_stream' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + integer, intent(out), optional :: ierr + + integer :: err_local + type (MPAS_stream_list_type), pointer :: stream, alarm_cursor, delete_me + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_destroy_stream()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Remove stream from list + ! + call MPAS_stream_list_remove(manager % streams, streamID, stream, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while removing stream from list') + return + end if + + ! + ! Unlink stream from input alarms + ! + alarm_cursor => stream % alarmList_in % head + do while (associated(alarm_cursor)) + call MPAS_stream_list_remove(alarm_cursor % xref % streamList, streamID, delete_me, ierr=err_local) + if (err_local == MPAS_STREAM_LIST_NOERR) then + deallocate(delete_me) + else + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while removing stream from list of input alarm') + return + end if + alarm_cursor => alarm_cursor % next + end do + + ! + ! Unlink stream from output alarms + ! + alarm_cursor => stream % alarmList_out % head + do while (associated(alarm_cursor)) + call MPAS_stream_list_remove(alarm_cursor % xref % streamList, streamID, delete_me, ierr=err_local) + if (err_local == MPAS_STREAM_LIST_NOERR) then + deallocate(delete_me) + else + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while removing stream from list of output alarm') + return + end if + alarm_cursor => alarm_cursor % next + end do + + ! + ! Free up stream storage -- reverse of whatever was done when allocating the stream + ! + call MPAS_stream_list_destroy(stream % alarmList_in, ierr=err_local) + call MPAS_stream_list_destroy(stream % alarmList_out, ierr=err_local) + call mpas_pool_destroy_pool(stream % att_pool) + call mpas_pool_destroy_pool(stream % field_pool) + call mpas_pool_destroy_pool(stream % pkg_pool) + if (associated(stream % referenceTime)) then + deallocate(stream % referenceTime) + end if + if (associated(stream % recordInterval)) then + deallocate(stream % recordInterval) + end if + if (stream % valid) then + call MPAS_closeStream(stream % stream, ierr=err_local) + if (err_local /= MPAS_STREAM_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while closing stream '//trim(stream % name)) + end if + deallocate(stream % stream) + end if + deallocate(stream) + + manager % numStreams = manager % numStreams - 1 + + end subroutine MPAS_stream_mgr_destroy_stream!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_get_clock + ! + !> \brief Retrieves the clock used by the stream manager. + !> \author Michael Duda + !> \date 22 August 2014 + !> \details + !> Returns a pointer to the clock associated with the stream manager, + !> in which any stream alarms should be defined before being added to + !> the stream manager via the MPAS_stream_mgr_add_alarm() routine. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_get_clock(manager, clock, ierr) !{{{ + + implicit none + + type (MPAS_streamManager_type), intent(in) :: manager + type (MPAS_Clock_type), pointer :: clock + integer, intent(out), optional :: ierr + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_get_clock()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + clock => manager % streamClock + + end subroutine MPAS_stream_mgr_get_clock !}}} + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_pool + ! + !> \brief Add a pool of fields to the specified stream in an MPAS stream manager. + !> \author Doug Jacobsen + !> \date 09/15/2014 + !> \details + !> Adds a pool from the allStructs pool to the specified stream in an MPAS + !> stream manager. Currently, it adds only explicitly named var's and + !> var_array's to the stream, but commented code will allow adding all nested + !> structs as well. + ! + !----------------------------------------------------------------------- + recursive subroutine MPAS_stream_mgr_add_pool(manager, streamID, poolName, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_pool' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + character (len=*), intent(in) :: poolName + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream + type (mpas_pool_field_info_type) :: info + integer, pointer :: test_ptr + integer :: err_local + + type (mpas_pool_type), pointer :: fieldPool + type (mpas_pool_iterator_type) :: poolItr + + type (field0DReal), pointer :: real0DField + type (field1DReal), pointer :: real1DField + type (field2DReal), pointer :: real2DField + type (field3DReal), pointer :: real3DField + type (field4DReal), pointer :: real4DField + type (field5DReal), pointer :: real5DField + type (field0DInteger), pointer :: int0DField + type (field1DInteger), pointer :: int1DField + type (field2DInteger), pointer :: int2DField + type (field3DInteger), pointer :: int3DField + type (field0DChar), pointer :: char0DField + type (field1DChar), pointer :: char1DField + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_pool()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Check that stream exists + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' does not exist in stream manager') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Don't modify an immutable stream + ! + if (stream % immutable) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' is immutable.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Check that the pool exists + ! + call mpas_pool_get_subpool(manager % allStructs, poolName, fieldPool) + if (.not. associated(fieldPool) ) then + STREAM_ERROR_WRITE('Requested pool '//trim(poolName)//' does not exist.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Iterate over pool, adding each field to the stream, and recursively calling this subroutine for each subpool + ! + call mpas_pool_begin_iteration(fieldPool) + do while (mpas_pool_get_next_member(fieldPool, poolItr)) + if (poolItr % memberType == MPAS_POOL_SUBPOOL) then + STREAM_DEBUG_WRITE('-- Try to add subpool...') + ! call mpas_stream_mgr_add_pool(manager, streamId, poolItr % memberName, iErr) + else if (poolItr % memberType == MPAS_POOL_FIELD) then + if (poolItr % dataType == MPAS_POOL_REAL) then + if (poolItr % nDims == 0) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, real0DField) + call mpas_stream_mgr_add_field(manager, streamID, real0DField % fieldName, ierr) + else if (poolItr % nDims == 1) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, real1DField) + call mpas_stream_mgr_add_field(manager, streamID, real1DField % fieldName, ierr) + else if (poolItr % nDims == 2) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, real2DField) + call mpas_stream_mgr_add_field(manager, streamID, real2DField % fieldName, ierr) + else if (poolItr % nDims == 3) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, real3DField) + call mpas_stream_mgr_add_field(manager, streamID, real3DField % fieldName, ierr) + else if (poolItr % nDims == 4) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, real4DField) + call mpas_stream_mgr_add_field(manager, streamID, real4DField % fieldName, ierr) + else if (poolItr % nDims == 5) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, real5DField) + call mpas_stream_mgr_add_field(manager, streamID, real5DField % fieldName, ierr) + end if + else if (poolItr % dataType == MPAS_POOL_INTEGER) then + if (poolItr % nDims == 0) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, int0DField) + call mpas_stream_mgr_add_field(manager, streamID, int0DField % fieldName, ierr) + else if (poolItr % nDims == 1) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, int1DField) + call mpas_stream_mgr_add_field(manager, streamID, int1DField % fieldName, ierr) + else if (poolItr % nDims == 2) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, int2DField) + call mpas_stream_mgr_add_field(manager, streamID, int2DField % fieldName, ierr) + else if (poolItr % nDims == 3) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, int3DField) + call mpas_stream_mgr_add_field(manager, streamID, int3DField % fieldName, ierr) + end if + else if (poolItr % dataType == MPAS_POOL_CHARACTER) then + if (poolItr % nDims == 0) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, char0DField) + call mpas_stream_mgr_add_field(manager, streamID, char0DField % fieldName, ierr) + else if (poolItr % nDims == 1) then + call mpas_pool_get_field(fieldPool, poolItr % memberName, char1DField) + call mpas_stream_mgr_add_field(manager, streamID, char1DField % fieldName, ierr) + end if + end if + end if + end do + + end subroutine MPAS_stream_mgr_add_pool!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_field + ! + !> \brief Add a field to the specified stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Adds a field from the allFields pool to a stream. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_add_field(manager, streamID, fieldName, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_field' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + character (len=*), intent(in) :: fieldName + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream + type (mpas_pool_field_info_type) :: info + integer, pointer :: test_ptr + integer :: err_level + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_field()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Check that stream exists + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' does not exist in stream manager') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Don't modify an immutable stream + ! + if (stream % immutable) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' is immutable.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Check that field exists + ! + info % nDims = -1 + call mpas_pool_get_field_info(manager % allFields, fieldName, info) + if (info % nDims == -1) then + STREAM_ERROR_WRITE('Requested field '//trim(fieldName)//' not available') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Check that the field does not already exist in the stream + ! + nullify(test_ptr) + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + call mpas_pool_get_config(stream % field_pool, fieldName, value=test_ptr) + call mpas_pool_set_error_level(err_level) + if (associated(test_ptr)) then + STREAM_ERROR_WRITE('Requested field '//trim(fieldName)//' already in stream '//trim(streamID)) + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Add field to field pool in stream if the field is activated + ! + if (info % isActive) then + call mpas_pool_add_config(stream % field_pool, fieldName, 1) + else + write(stderrUnit, *) ' * Requested field '//trim(fieldName)//' is deactivated due to packages, or is a scratch variable.' + end if + + end subroutine MPAS_stream_mgr_add_field!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_stream_fields + ! + !> \brief Add all fields from another stream to the specified stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 5 November 2014 + !> \details + !> Adds all fields from another specified stream into the new specified stream. + !> Both streams need to exist within the same stream manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_add_stream_fields(manager, streamID, refStreamID, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_stream_fields' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + character (len=*), intent(in) :: refStreamID + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream, refStream + type (mpas_pool_field_info_type) :: info + type (mpas_pool_iterator_type) :: itr + integer, pointer :: test_ptr + integer :: err_level + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_stream_fields()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Check that reference stream exists + ! + if (.not. MPAS_stream_list_query(manager % streams, refStreamID, refStream, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested reference stream '//trim(refStreamID)//' does not exist in stream manager') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Check that stream exists + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' does not exist in stream manager') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Don't modify an immutable stream + ! + if (stream % immutable) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' is immutable.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Loop over all fields in refStream and add them one by one to stream + ! + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + call mpas_pool_begin_iteration(refStream % field_pool) + do while (mpas_pool_get_next_member(refStream % field_pool, itr)) + if ( itr % memberType == MPAS_POOL_CONFIG ) then + if ( itr % dataType == MPAS_POOL_INTEGER ) then + + ! + ! Check that field exists + ! + info % nDims = -1 + call mpas_pool_get_field_info(manager % allFields, itr % memberName, info) + if (info % nDims == -1) then + STREAM_ERROR_WRITE('Requested field '//trim(itr % memberName)//' not available') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! Test that the field does not already exist in stream + nullify(test_ptr) + call mpas_pool_get_config(stream % field_pool, itr % memberName, value=test_ptr) + + if ( associated(test_ptr) ) then + STREAM_ERROR_WRITE('Requested field '//trim(itr % memberName)//' already in stream '//trim(streamID)) + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + end if + + if ( info % isActive ) then + call mpas_pool_add_config(stream % field_pool, itr % memberName, 1) + else + write(stderrUnit, *) ' * Requested field '//trim(itr % memberName)//' is deactivated due to packages, or is a scratch variable.' + end if + + end if + end if + end do + call mpas_pool_set_error_level(err_level) + + end subroutine MPAS_stream_mgr_add_stream_fields!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_remove_field + ! + !> \brief Remove a field from the specified stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Removes a field from a stream. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_remove_field(manager, streamID, fieldName, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_remove_field' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + character (len=*), intent(in) :: fieldName + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream + integer, pointer :: test_ptr + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_remove_field()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Check that stream exists + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' does not exist in stream manager') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Don't modify an immutable stream + ! + if (stream % immutable) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' is immutable.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Check that field exists in stream's field pool + ! + nullify(test_ptr) + call mpas_pool_get_config(stream % field_pool, fieldName, value=test_ptr) + if (.not. associated(test_ptr)) then + STREAM_ERROR_WRITE('Requested field '//trim(fieldName)//' not in stream '//trim(streamID)) + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Remove field from stream's field pool + ! + call mpas_pool_remove_config(stream % field_pool, fieldName) + + end subroutine MPAS_stream_mgr_remove_field!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_alarm + ! + !> \brief Add an I/O alarm to a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> This routine will add a stream direction to be associated with an + !> alarm. It will not add the alarm to the manager's clock, but it is assumed + !> that the alarmID is used in the clock's alarm list. + !> + !> It will create a subpool within the alarms pool that represents the + !> alarm (if it doesn't exist already). The pool representing this stream + !> will be added to the alarm pool, along with an integer that has the same + !> name as the stream whose value will represent the direction the stream + !> will be handled when this alarm rings. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_add_alarm(manager, streamID, alarmID, direction, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_alarm' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + character (len=*), intent(in) :: alarmID + integer, intent(in) :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream, new_alarm, new_xref + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_alarm()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Check that stream exists + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' does not exist in stream manager') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Check that the specified direction makes sense for the stream + ! + if (stream % direction == MPAS_STREAM_OUTPUT .and. direction == MPAS_STREAM_INPUT .or. & + stream % direction == MPAS_STREAM_OUTPUT .and. direction == MPAS_STREAM_INPUT_OUTPUT .or. & + stream % direction == MPAS_STREAM_INPUT .and. direction == MPAS_STREAM_OUTPUT .or. & + stream % direction == MPAS_STREAM_INPUT .and. direction == MPAS_STREAM_INPUT_OUTPUT .or. & + stream % direction == MPAS_STREAM_NONE) then + + STREAM_ERROR_WRITE('Attempting to add an alarm '//trim(alarmID)//' to invalid direction for stream '//trim(streamID)) + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Check that alarm exists on clock + ! + if (.not. mpas_is_alarm_defined(manager % streamClock, alarmID, err_local)) then + STREAM_ERROR_WRITE('Attempting to add an alarm '//trim(alarmID)//' that does not exist on clock') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Check that the alarm does not already exist for the stream in the specified direction + ! + if (direction == MPAS_STREAM_INPUT .or. direction == MPAS_STREAM_INPUT_OUTPUT) then + if (MPAS_stream_list_query(stream % alarmList_in, alarmID, new_alarm, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested input alarm '//trim(alarmID)//' already on stream '//trim(streamID)) + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + end if + if (direction == MPAS_STREAM_OUTPUT .or. direction == MPAS_STREAM_INPUT_OUTPUT) then + if (MPAS_stream_list_query(stream % alarmList_out, alarmID, new_alarm, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested output alarm '//trim(alarmID)//' already on stream '//trim(streamID)) + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + end if + + + ! + ! Add alarm to alarm to the alarms_in and/or alarms_out list + ! Add alarm to the alarmList_in and/or alarmList_out list for the field + ! + if (direction == MPAS_STREAM_INPUT .or. direction == MPAS_STREAM_INPUT_OUTPUT) then + + ! If alarm is not already defined, we need to create a new alarm node + if (.not. MPAS_stream_list_query(manager % alarms_in, alarmID, new_alarm, ierr=err_local)) then + allocate(new_alarm) + new_alarm % name = alarmID + call MPAS_stream_list_create(new_alarm % streamList, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while creating stream list for alarm') + return + end if + nullify(new_alarm % next) + + call MPAS_stream_list_insert(manager % alarms_in, new_alarm, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while adding input alarm to list') + return + end if + end if + + ! Add specified stream to alarm node stream list + allocate(new_xref) + new_xref % name = streamID + new_xref % xref => stream + call MPAS_stream_list_insert(new_alarm % streamList, new_xref, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while adding stream to alarm stream list') + return + end if + + ! Add alarm to stream alarm list + allocate(new_xref) + new_xref % name = alarmID + new_xref % xref => new_alarm + call MPAS_stream_list_insert(stream % alarmList_in, new_xref, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while adding alarm to stream input alarm list') + return + end if + end if + + if (direction == MPAS_STREAM_OUTPUT .or. direction == MPAS_STREAM_INPUT_OUTPUT) then + + ! If alarm is not already defined, we need to create a new alarm node + if (.not. MPAS_stream_list_query(manager % alarms_out, alarmID, new_alarm, ierr=err_local)) then + allocate(new_alarm) + new_alarm % name = alarmID + call MPAS_stream_list_create(new_alarm % streamList, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while creating stream list for alarm') + return + end if + nullify(new_alarm % next) + + call MPAS_stream_list_insert(manager % alarms_out, new_alarm, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while adding output alarm to list') + return + end if + end if + + ! Add specified stream to alarm node stream list + allocate(new_xref) + new_xref % name = streamID + new_xref % xref => stream + call MPAS_stream_list_insert(new_alarm % streamList, new_xref, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while adding stream to alarm stream list') + return + end if + + ! Add alarm to stream alarm list + allocate(new_xref) + new_xref % name = alarmID + new_xref % xref => new_alarm + call MPAS_stream_list_insert(stream % alarmList_out, new_xref, ierr=err_local) + if (err_local /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while adding alarm to stream output alarm list') + return + end if + end if + + end subroutine MPAS_stream_mgr_add_alarm!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_remove_alarm + ! + !> \brief Remove an I/O alarm from a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> This routine will remove the association of a stream to an alarm from + !> the stream manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_remove_alarm(manager, streamID, alarmID, direction, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_remove_alarm' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + character (len=*), intent(in) :: alarmID + integer, intent(in) :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream + type (MPAS_stream_list_type), pointer :: alarmNode + type (MPAS_stream_list_type), pointer :: streamNode + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_remove_alarm()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Check that stream exists + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream, ierr=err_local)) then + STREAM_ERROR_WRITE('Requested stream '//trim(streamID)//' does not exist in stream manager') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Unlink alarm from alarmList_in or alarmList_out for stream + ! + nullify(alarmNode) + if (direction == MPAS_STREAM_INPUT) then + call MPAS_stream_list_remove(stream % alarmList_in, alarmID, alarmNode, ierr=ierr) + else if (direction == MPAS_STREAM_OUTPUT) then + call MPAS_stream_list_remove(stream % alarmList_out, alarmID, alarmNode, ierr=ierr) + else + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Requested to remove alarm from invalid direction from stream '//trim(streamID)) + return + end if + + ! + ! Remove stream from alarm's streamList in alarms_in or alarms_out + ! + if (associated(alarmNode)) then + call MPAS_stream_list_remove(alarmNode % xref % streamList, streamID, streamNode, ierr=ierr) + else + if (direction == MPAS_STREAM_INPUT) then + STREAM_ERROR_WRITE('Input alarm '//trim(alarmID)//' does not exist on stream '//trim(streamID)) + else + STREAM_ERROR_WRITE('Output alarm '//trim(alarmID)//' does not exist on stream '//trim(streamID)) + end if + return + end if + if (.not. associated(streamNode)) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Alarm '//trim(alarmID)//' does not have stream '//trim(streamID)//' on its stream list.') + return + end if + + ! + ! If the alarm has no associated streams, should we remove it from alarms_in or alarms_out? + ! + if (MPAS_stream_list_length(alarmNode % xref % streamList) == 0) then + if (direction == MPAS_STREAM_INPUT) then + STREAM_ERROR_WRITE('Input alarm '//trim(alarmID)//' has no associated streams and will be deleted.') + call MPAS_stream_list_remove(manager % alarms_in, alarmID, alarmNode, ierr=ierr) + else + STREAM_ERROR_WRITE('Output alarm '//trim(alarmID)//' has no associated streams and will be deleted.') + call MPAS_stream_list_remove(manager % alarms_out, alarmID, alarmNode, ierr=ierr) + end if + end if + + end subroutine MPAS_stream_mgr_remove_alarm!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_reset_alarms + ! + !> \brief Reset I/O alarms in a stream manager + !> \author Michael Duda + !> \date 2 September 2014 + !> \details + !> Resets all alarms used by the stream manager. If the optional argument + !> 'streamID' is provided, only alarms associated with that stream will be + !> reset. If the optional 'direction' argument is provided, only alarms + !> associated with that direction will be reset. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_reset_alarms(manager, streamID, direction, ierr)!{{{ + + implicit none + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in), optional :: streamID + integer, intent(in), optional :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream + type (MPAS_stream_list_type), pointer :: alarm_cursor + integer :: local_direction + integer :: local_ierr + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_reset_alarms()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + + ! + ! Check for optional direction argument; default direction is both input and output. + ! + if (present(direction)) then + local_direction = direction + else + local_direction = MPAS_STREAM_INPUT_OUTPUT + end if + + + ! + ! Check for optional streamID argument; default is to handle all alarms in the manager. + ! + nullify(stream) + if (present(streamID)) then + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream, ierr=local_ierr)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in stream manager.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + end if + + + if (local_direction == MPAS_STREAM_INPUT .or. local_direction == MPAS_STREAM_INPUT_OUTPUT) then + if (associated(stream)) then + alarm_cursor => stream % alarmList_in % head + else + alarm_cursor => manager % alarms_in % head + end if + do while (associated(alarm_cursor)) + if (mpas_is_alarm_ringing(manager % streamClock, alarm_cursor % name, ierr=local_ierr)) then + call mpas_reset_clock_alarm(manager % streamClock, alarm_cursor % name, ierr=local_ierr) + end if + alarm_cursor => alarm_cursor % next + end do + end if + + + if (local_direction == MPAS_STREAM_OUTPUT .or. local_direction == MPAS_STREAM_INPUT_OUTPUT) then + if (associated(stream)) then + alarm_cursor => stream % alarmList_out % head + else + alarm_cursor => manager % alarms_out % head + end if + do while (associated(alarm_cursor)) + if (mpas_is_alarm_ringing(manager % streamClock, alarm_cursor % name, ierr=local_ierr)) then + call mpas_reset_clock_alarm(manager % streamClock, alarm_cursor % name, ierr=local_ierr) + end if + alarm_cursor => alarm_cursor % next + end do + end if + + end subroutine MPAS_stream_mgr_reset_alarms!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_ringing_alarms + ! + !> \brief Test whether any I/O alarms in a stream manager are ringing + !> \author Michael Duda + !> \date 30 September 2014 + !> \details + !> Tests whether any I/O alarms in a stream manager are ringing; if the optional + !> 'streamID' argument is given, only alarms for that stream are tested; if + !> the optional argument 'direction' is given, only alarms for the specified + !> direction are tested. If any of the tested alarms is ringing, the function + !> returns .true.; otherwise, it returns .false.. + ! + !----------------------------------------------------------------------- + logical function MPAS_stream_mgr_ringing_alarms(manager, streamID, direction, ierr) !{{{ + + implicit none + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in), optional :: streamID + integer, intent(in), optional :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream + type (MPAS_stream_list_type), pointer :: alarm_cursor + integer :: local_direction + integer :: local_ierr + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_ringing_alarms()') + + MPAS_stream_mgr_ringing_alarms = .false. + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + + ! + ! Check for optional direction argument; default direction is both input and output. + ! + if (present(direction)) then + local_direction = direction + else + local_direction = MPAS_STREAM_INPUT_OUTPUT + end if + + + ! + ! Check for optional streamID argument; default is to handle all alarms in the manager. + ! + nullify(stream) + if (present(streamID)) then + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream, ierr=local_ierr)) then + STREAM_DEBUG_WRITE('-- Stream '//trim(streamID)//' does not exist in stream manager.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + end if + + + if (local_direction == MPAS_STREAM_INPUT .or. local_direction == MPAS_STREAM_INPUT_OUTPUT) then + if (associated(stream)) then + alarm_cursor => stream % alarmList_in % head + else + alarm_cursor => manager % alarms_in % head + end if + do while (associated(alarm_cursor)) + if (mpas_is_alarm_ringing(manager % streamClock, alarm_cursor % name, ierr=local_ierr)) then + MPAS_stream_mgr_ringing_alarms = .true. + return + end if + alarm_cursor => alarm_cursor % next + end do + end if + + + if (local_direction == MPAS_STREAM_OUTPUT .or. local_direction == MPAS_STREAM_INPUT_OUTPUT) then + if (associated(stream)) then + alarm_cursor => stream % alarmList_out % head + else + alarm_cursor => manager % alarms_out % head + end if + do while (associated(alarm_cursor)) + if (mpas_is_alarm_ringing(manager % streamClock, alarm_cursor % name, ierr=local_ierr)) then + MPAS_stream_mgr_ringing_alarms = .true. + return + end if + alarm_cursor => alarm_cursor % next + end do + end if + + end function MPAS_stream_mgr_ringing_alarms !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_set_property_int + ! + !> \brief Sets a property of a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Sets the value of a stream property within an MPAS stream manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_set_property_int(manager, streamID, propertyName, propertyValue, direction, ierr) !{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_set_property_int' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + integer, intent(in) :: propertyName + integer, intent(in) :: propertyValue + integer, intent(in), optional :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: err_local + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_set_property()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Find requested stream + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_set_property().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Set property + ! + select case (propertyName) + + case (MPAS_STREAM_PROPERTY_PRECISION) + stream_cursor % precision = propertyValue + + case (MPAS_STREAM_PROPERTY_CLOBBER) + stream_cursor % clobber_mode = propertyValue + + case default + STREAM_ERROR_WRITE('MPAS_stream_mgr_set_property(): No such property ' COMMA propertyName) + STREAM_ERROR_WRITE(' or specified property is not of type integer.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + end select + + end subroutine MPAS_stream_mgr_set_property_int !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_set_property_char + ! + !> \brief Sets a property of a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Sets the value of a stream property within an MPAS stream manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_set_property_char(manager, streamID, propertyName, propertyValue, direction, ierr) !{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_set_property_char' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + integer, intent(in) :: propertyName + character (len=*), intent(in) :: propertyValue + integer, intent(in), optional :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: err_local + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_set_property()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Find requested stream + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_set_property().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Set property + ! + select case (propertyName) + + case (MPAS_STREAM_PROPERTY_FILENAME) +!TODO: ensure that filename does not contain ':' characters, which PNETCDF does not like... + stream_cursor % filename_template = propertyValue + + case (MPAS_STREAM_PROPERTY_FILENAME_INTV) + stream_cursor % filename_interval = propertyValue + + case (MPAS_STREAM_PROPERTY_REF_TIME) + call mpas_set_time(stream_cursor % referenceTime, dateTimeString=propertyValue) + + case (MPAS_STREAM_PROPERTY_RECORD_INTV) + + ! The interval between records may not have been allocated if the optional recordInterval + ! argument was not provided when the stream was created + if (.not. associated(stream_cursor % recordInterval)) then + allocate(stream_cursor % recordInterval) + end if + call mpas_set_timeInterval(stream_cursor % recordInterval, timeString=propertyValue) + + case default + STREAM_ERROR_WRITE(' MPAS_stream_mgr_set_property(): No such property ' COMMA propertyName) + STREAM_ERROR_WRITE(' or specified property is not of type character.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + end select + + end subroutine MPAS_stream_mgr_set_property_char !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_set_property_logical + ! + !> \brief Sets a property of a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Sets the value of a stream property within an MPAS stream manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_set_property_logical(manager, streamID, propertyName, propertyValue, direction, ierr) !{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_set_property_logical' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + integer, intent(in) :: propertyName + logical, intent(in) :: propertyValue + integer, intent(in), optional :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: err_local + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_set_property()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Find requested stream + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_set_property().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Set property + ! + select case (propertyName) + + case (MPAS_STREAM_PROPERTY_ACTIVE) + stream_cursor % active_stream = propertyValue + + case (MPAS_STREAM_PROPERTY_IMMUTABLE) + stream_cursor % immutable = propertyValue + + case default + STREAM_ERROR_WRITE(' MPAS_stream_mgr_set_property(): No such property ' COMMA propertyName) + STREAM_ERROR_WRITE(' or specified property is not of type logical.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + end select + + end subroutine MPAS_stream_mgr_set_property_logical !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_get_property_int + ! + !> \brief Sets a property of a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Retrieves the value of a stream property within an MPAS stream manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_get_property_int(manager, streamID, propertyName, propertyValue, direction, ierr) !{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_set_property_int' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + integer, intent(in) :: propertyName + integer, intent(out) :: propertyValue + integer, intent(in), optional :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: err_local + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_get_property()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Find requested stream + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_get_property().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Set property + ! + select case (propertyName) + + case (MPAS_STREAM_PROPERTY_PRECISION) + propertyValue = stream_cursor % precision + + case (MPAS_STREAM_PROPERTY_CLOBBER) + propertyValue = stream_cursor % clobber_mode + + case default + STREAM_ERROR_WRITE('MPAS_stream_mgr_get_property(): No such property ' COMMA propertyName) + STREAM_ERROR_WRITE(' or specified property is not of type integer.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + end select + + end subroutine MPAS_stream_mgr_get_property_int !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_get_property_char + ! + !> \brief Sets a property of a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Retrieves the value of a stream property within an MPAS stream manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_get_property_char(manager, streamID, propertyName, propertyValue, direction, ierr) !{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_get_property_char' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + integer, intent(in) :: propertyName + character (len=*), intent(out) :: propertyValue + integer, intent(in), optional :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + type (MPAS_stream_list_type), pointer :: alarm_cursor + type (MPAS_timeInterval_type) :: temp_interval, interval + integer :: nAlarms + integer :: err_local + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_get_property()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Find requested stream + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_get_property().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Set property + ! + select case (propertyName) + + case (MPAS_STREAM_PROPERTY_FILENAME) + propertyValue = stream_cursor % filename_template + + case (MPAS_STREAM_PROPERTY_FILENAME_INTV) + propertyValue = stream_cursor % filename_interval + + case (MPAS_STREAM_PROPERTY_REF_TIME) + call mpas_get_time(stream_cursor % referenceTime, dateTimeString=propertyValue) + + case (MPAS_STREAM_PROPERTY_RECORD_INTV) + + ! The interval between records may not have been allocated if the optional recordInterval + ! argument was not provided when the stream was created. If there is no explicit recordInterval, + ! assume that the interval is the shortest interval between alarms on the stream; since + ! recordInterval is only used for reading, use the input alarm list in this check. + if (.not. associated(stream_cursor % recordInterval)) then + + ! + ! If no direction is specified, return the read interval, since this was the only historic + ! use of the recordInterval for a stream. + ! + if (present(direction)) then + if (direction == MPAS_STREAM_OUTPUT) then + alarm_cursor => stream_cursor % alarmList_out % head + else + alarm_cursor => stream_cursor % alarmList_in % head + end if + else + alarm_cursor => stream_cursor % alarmList_in % head + end if + nAlarms = 0 + do while (associated(alarm_cursor)) + temp_interval = mpas_alarm_interval(manager % streamClock, alarm_cursor % name, err_local) + if (err_local == 0) then + if (nAlarms == 0) then + interval = temp_interval + else if (temp_interval < interval) then + interval = temp_interval + end if + nAlarms = nAlarms + 1 + end if + alarm_cursor => alarm_cursor % next + end do + if (nAlarms > 0) then + call mpas_get_timeInterval(interval, timeString=propertyValue) + else + propertyValue = 'none' + end if + else + call mpas_get_timeInterval(stream_cursor % recordInterval, timeString=propertyValue) + end if + + case default + STREAM_ERROR_WRITE(' MPAS_stream_mgr_get_property(): No such property ' COMMA propertyName) + STREAM_ERROR_WRITE(' or specified property is not of type character.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + end select + + end subroutine MPAS_stream_mgr_get_property_char !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_get_property_logical + ! + !> \brief Sets a property of a stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Retrieves the value of a stream property within an MPAS stream manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_get_property_logical(manager, streamID, propertyName, propertyValue, direction, ierr) !{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_get_property' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + integer, intent(in) :: propertyName + logical, intent(out) :: propertyValue + integer, intent(in), optional :: direction + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: err_local + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_get_property_logical()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Find requested stream + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_get_property().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Set property + ! + select case (propertyName) + + case (MPAS_STREAM_PROPERTY_ACTIVE) + propertyValue = stream_cursor % active_stream + + case (MPAS_STREAM_PROPERTY_IMMUTABLE) + propertyValue = stream_cursor % immutable + + case default + STREAM_ERROR_WRITE('MPAS_stream_mgr_get_property(): No such property ' COMMA propertyName) + STREAM_ERROR_WRITE(' or specified property is not of type logical.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + end select + + end subroutine MPAS_stream_mgr_get_property_logical !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_pkg + ! + !> \brief Attach a package logical to the specified stream. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Attaches a package logical to a specific stream within an MPAS stream + !> manager. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_add_pkg(manager, streamID, packageName, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_pkg' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + character (len=*), intent(in) :: packageName + integer, intent(out), optional :: ierr + + logical, pointer :: package + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_pkg()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Query pointer to package in the manager-wide package pool + ! + nullify(package) + call mpas_pool_get_package(manager % allPackages, packageName, package) + if (.not. associated(package)) then + STREAM_ERROR_WRITE('Package '//trim(packageName)//' not found in call to MPAS_stream_mgr_add_pkg().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Find requested stream + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_add_pkg().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Add package to the packages pool for the stream + ! + call mpas_pool_add_package(stream_cursor % pkg_pool, packageName, package) + + end subroutine MPAS_stream_mgr_add_pkg!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_remove_pkg + ! + !> \brief Detaches a package logical from the specified stream. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Removes a package from a stream, so the package no longer controls + !> whether or not the stream is active. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_remove_pkg(manager, streamID, packageName, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_remove_pkg' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: streamID + character (len=*), intent(in), target :: packageName + integer, intent(out), optional :: ierr + + logical, pointer :: package + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_remove_pkg()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Find requested stream + ! + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_remove_pkg().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Remove package from the packages pool for the stream + ! + call mpas_pool_remove_package(stream_cursor % pkg_pool, packageName) + + end subroutine MPAS_stream_mgr_remove_pkg!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_att_int + ! + !> \brief Add an integer attribute to the specified stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Add a global integer attribute to the stream within an MPAS stream manager. + !> If the optional streamID argument is not supplied, the attribute will be + !> applied to every stream created after the call to add the attribute. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_add_att_int(manager, attName, attVal, streamID, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_att_int' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: attName + integer, intent(in) :: attVal + character (len=*), intent(in), optional :: streamID + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + type (MPAS_pool_type), pointer :: att_pool + integer, pointer :: queryVal + integer :: att_type + integer :: err_level + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_att()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + nullify(queryVal) + + if (present(streamID)) then + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_add_att().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + att_pool => stream_cursor % att_pool + else + att_pool => manager % defaultAtts + end if + + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + call mpas_pool_get_config(att_pool, attName, queryVal) + call mpas_pool_set_error_level(err_level) + if (.not. associated(queryVal)) then + ! + ! Querying the type of the attribute should return MPAS_POOL_FATAL if the attribute really + ! does not exist in the pool; otherwise, the attribute exists but was of the wrong type + ! in the call above to mpas_pool_get_config() + ! + if (mpas_pool_config_type(att_pool, attName) /= MPAS_POOL_FATAL) then + STREAM_ERROR_WRITE('Attribute '//trim(attName)//' in stream '//trim(streamID)//' is not of type integer.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + call mpas_pool_add_config(att_pool, attName, attVal) + else + queryVal = attVal + end if + + end subroutine MPAS_stream_mgr_add_att_int!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_att_real + ! + !> \brief Add a real attribute to the specified stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Add a global real attribute to the stream within an MPAS stream manager. + !> If the optional streamID argument is not supplied, the attribute will be + !> applied to every stream created after the call to add the attribute. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_add_att_real(manager, attName, attVal, streamID, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_att_real' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: attName + real (kind=RKIND), intent(in) :: attVal + character (len=*), intent(in), optional :: streamID + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + type (MPAS_pool_type), pointer :: att_pool + real (kind=RKIND), pointer :: queryVal + integer :: att_type + integer :: err_level + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_att()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + nullify(queryVal) + + if (present(streamID)) then + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_add_att().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + att_pool => stream_cursor % att_pool + else + att_pool => manager % defaultAtts + end if + + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + call mpas_pool_get_config(att_pool, attName, queryVal) + call mpas_pool_set_error_level(err_level) + if (.not. associated(queryVal)) then + ! + ! Querying the type of the attribute should return MPAS_POOL_FATAL if the attribute really + ! does not exist in the pool; otherwise, the attribute exists but was of the wrong type + ! in the call above to mpas_pool_get_config() + ! + if (mpas_pool_config_type(att_pool, attName) /= MPAS_POOL_FATAL) then + STREAM_ERROR_WRITE('Attribute '//trim(attName)//' in stream '//trim(streamID)//' is not of type real.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + call mpas_pool_add_config(att_pool, attName, attVal) + else + queryVal = attVal + end if + + end subroutine MPAS_stream_mgr_add_att_real!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_att_char + ! + !> \brief Add a character attribute to the specified stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Add a global character attribute to the stream within an MPAS stream manager. + !> If the optional streamID argument is not supplied, the attribute will be + !> applied to every stream created after the call to add the attribute. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_add_att_char(manager, attName, attVal, streamID, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_att_char' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: attName + character (len=*), intent(in) :: attVal + character (len=*), intent(in), optional :: streamID + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + type (MPAS_pool_type), pointer :: att_pool + character (len=StrKIND), pointer :: queryVal + integer :: att_type + integer :: err_level + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_att()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + nullify(queryVal) + + if (present(streamID)) then + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_add_att().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + att_pool => stream_cursor % att_pool + else + att_pool => manager % defaultAtts + end if + + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + call mpas_pool_get_config(att_pool, attName, queryVal) + call mpas_pool_set_error_level(err_level) + if (.not. associated(queryVal)) then + ! + ! Querying the type of the attribute should return MPAS_POOL_FATAL if the attribute really + ! does not exist in the pool; otherwise, the attribute exists but was of the wrong type + ! in the call above to mpas_pool_get_config() + ! + if (mpas_pool_config_type(att_pool, attName) /= MPAS_POOL_FATAL) then + STREAM_ERROR_WRITE('Attribute '//trim(attName)//' in stream '//trim(streamID)//' is not of type character.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + call mpas_pool_add_config(att_pool, attName, attVal) + else + queryVal = attVal + end if + + end subroutine MPAS_stream_mgr_add_att_char!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_add_att_logical + ! + !> \brief Add a logical attribute to the specified stream in an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> Add a global logical attribute to the stream within an MPAS stream manager. + !> If the optional streamID argument is not supplied, the attribute will be + !> applied to every stream created after the call to add the attribute. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_add_att_logical(manager, attName, attVal, streamID, ierr)!{{{ + + implicit none + + character (len=*), parameter :: sub = 'MPAS_stream_mgr_add_att_logical' + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in) :: attName + logical, intent(in) :: attVal + character (len=*), intent(in), optional :: streamID + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + type (MPAS_pool_type), pointer :: att_pool + logical, pointer :: queryVal + integer :: att_type + integer :: err_level + integer :: err_local + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_add_att()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + nullify(queryVal) + + if (present(streamID)) then + if (.not. MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=err_local)) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_add_att().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + att_pool => stream_cursor % att_pool + else + att_pool => manager % defaultAtts + end if + + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + call mpas_pool_get_config(att_pool, attName, queryVal) + call mpas_pool_set_error_level(err_level) + if (.not. associated(queryVal)) then + ! + ! Querying the type of the attribute should return MPAS_POOL_FATAL if the attribute really + ! does not exist in the pool; otherwise, the attribute exists but was of the wrong type + ! in the call above to mpas_pool_get_config() + ! + if (mpas_pool_config_type(att_pool, attName) /= MPAS_POOL_FATAL) then + STREAM_ERROR_WRITE('Attribute '//trim(attName)//' in stream '//trim(streamID)//' is not of type logical.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + call mpas_pool_add_config(att_pool, attName, attVal) + else + queryVal = attVal + end if + + end subroutine MPAS_stream_mgr_add_att_logical!}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_write + ! + !> \brief Write streams that are managed by an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> With no optional arguments, writes all streams whose alarms are ringing. + !> The "streamID" argument optionally specifies the ID of a particular stream + !> to be written; if no other optional arguments are given, the specified + !> stream is only written if any of its alarms are ringing. + !> The "timeLevel" argument optionally specifies, for fields with multiple + !> time levels, the time level from which fields should be written. + !> The "mgLevel" argument optionally specifies, for fields that exist for + !> multiple grid levels, the grid level from which fields should be written. + !> The "forceWriteNow" argument optionally specifies that all streams -- or + !> the stream specified by the "streamID" argument -- should be written by + !> the call regardless of whether any alarms associated with the stream(s) + !> are ringing. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_write(manager, streamID, timeLevel, mgLevel, forceWriteNow, ierr) !{{{ + + implicit none + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in), optional :: streamID + integer, intent(in), optional :: timeLevel + integer, intent(in), optional :: mgLevel + logical, intent(in), optional :: forceWriteNow + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: local_timeLevel + integer :: local_mgLevel + logical :: local_forceWrite + integer :: local_ierr + integer :: temp_ierr + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_write()') + local_ierr = MPAS_STREAM_MGR_NOERR + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + + ! + ! Use optional arguments or set defaults + ! + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + if (present(mgLevel)) then + local_mgLevel = mgLevel + else + local_mgLevel = 1 + end if + + if (present(forceWriteNow)) then + local_forceWrite = forceWriteNow + else + local_forceWrite = .false. + end if + + + ! + ! If a stream is specified, we process just that stream; otherwise, + ! process all streams + ! + if (present(streamID)) then + nullify(stream_cursor) + if (MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=ierr)) then + STREAM_DEBUG_WRITE('-- Handling write of stream '//trim(stream_cursor % name)) + + ! Verify that the stream is an output stream + if (stream_cursor % direction /= MPAS_STREAM_OUTPUT .and. & + stream_cursor % direction /= MPAS_STREAM_INPUT_OUTPUT) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' is not an output stream.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + call write_stream(manager, stream_cursor, local_timeLevel, local_mgLevel, local_forceWrite, local_ierr) + else + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_write().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + else + nullify(stream_cursor) + stream_cursor => manager % streams % head + do while (associated(stream_cursor)) + STREAM_DEBUG_WRITE('-- Handling write of stream '//trim(stream_cursor % name)) + + ! Verify that the stream is an output stream + if (stream_cursor % direction == MPAS_STREAM_OUTPUT .or. & + stream_cursor % direction == MPAS_STREAM_INPUT_OUTPUT) then + + call write_stream(manager, stream_cursor, local_timeLevel, local_mgLevel, local_forceWrite, temp_ierr) + if (temp_ierr /= MPAS_STREAM_MGR_NOERR) then + local_ierr = temp_ierr + end if + + end if + stream_cursor => stream_cursor % next + end do + end if + + if (present(ierr)) ierr = local_ierr + + end subroutine MPAS_stream_mgr_write !}}} + + + !----------------------------------------------------------------------- + ! routine write_stream + ! + !> \brief Handle the writing of a stream pointed to by the stream list node + !> \author Michael Duda + !> \date 2 September 2014 + !> \details + !> Private subroutine to handle the details of actually writing a stream. + ! + !----------------------------------------------------------------------- + subroutine write_stream(manager, stream, timeLevel, mgLevel, forceWritenow, ierr) !{{{ + + implicit none + + type (MPAS_streamManager_type), intent(inout) :: manager + type (MPAS_stream_list_type), intent(inout) :: stream + integer, intent(in) :: timeLevel + integer, intent(in) :: mgLevel + logical, intent(in) :: forceWriteNow + integer, intent(out) :: ierr + + type (MPAS_stream_list_type), pointer :: alarm_cursor + type (MPAS_Time_type) :: now_time, ref_time + type (MPAS_TimeInterval_type) :: temp_interval + type (MPAS_TimeInterval_type) :: filename_interval + character (len=StrKIND) :: now_string, time_string + character (len=StrKIND) :: temp_filename, actualWhen + character (len=StrKIND) :: err_string + logical :: ringing_alarm, recordSeek, swapRecords + logical :: clobberRecords, clobberFiles, truncateFiles + integer :: maxRecords, tempRecord + integer :: local_ierr + + + ierr = MPAS_STREAM_MGR_NOERR + swapRecords = .false. + + ! + ! Check whether this stream is active + ! + if (.not. stream % active_stream) then + STREAM_DEBUG_WRITE('-- Stream '//trim(stream % name)//' is not currently active and will not be written.') + return + end if + + ! + ! Check whether all packages for this stream are inactive + ! Note: if the stream has no packages, it is assumed to be active + ! + if (.not. stream_active_pkg_check(stream)) then + STREAM_DEBUG_WRITE('-- Stream '//trim(stream % name)//' has only inactive packages and will not be written.') + return + end if + + ! + ! Check whether any of the output alarms for the stream are ringing + ! + ringing_alarm = .false. + alarm_cursor => stream % alarmList_out % head + do while (associated(alarm_cursor)) + if (mpas_is_alarm_ringing(manager % streamClock, alarm_cursor % name, ierr=local_ierr)) then + ringing_alarm = .true. + exit + end if + alarm_cursor => alarm_cursor % next + end do + + if ((.not. ringing_alarm) .and. (.not. forceWriteNow)) then + return + end if + + ! + ! Work out file clobbering options + ! + if (stream % clobber_mode == MPAS_STREAM_CLOBBER_OVERWRITE) then + clobberRecords = .true. + else + clobberRecords = .false. + end if + + if (stream % clobber_mode == MPAS_STREAM_CLOBBER_OVERWRITE .or. & + stream % clobber_mode == MPAS_STREAM_CLOBBER_TRUNCATE .or. & + stream % clobber_mode == MPAS_STREAM_CLOBBER_APPEND) then + clobberFiles = .true. + else + clobberFiles = .false. + end if + + if (stream % clobber_mode == MPAS_STREAM_CLOBBER_TRUNCATE) then + truncateFiles = .true. + else + truncateFiles = .false. + end if + + ! + ! If the stream is not valid, assume that we have not yet written this + ! stream, in which case we create the stream from scratch + ! + if (.not. stream % valid) then + if ( stream % filename_interval /= 'none' ) then + now_time = mpas_get_clock_time(manager % streamClock, MPAS_NOW, ierr=local_ierr) + call mpas_set_timeInterval(filename_interval, timeString=stream % filename_interval) + call build_filename(stream % referenceTime, now_time, filename_interval, stream % filename_template, stream % filename, ierr=local_ierr) + else + call mpas_get_time(stream % referenceTime, dateTimeString=time_string) + call mpas_expand_string(time_string, stream % filename_template, stream % filename) + end if + + stream % nRecords = 1 + + recordSeek = .false. + ! Based on clobber_mode, determine if it matters if the file exists or not. + if ( stream % clobber_mode == MPAS_STREAM_CLOBBER_OVERWRITE .or. stream % clobber_mode == MPAS_STREAM_CLOBBER_APPEND ) then + STREAM_DEBUG_WRITE(' -- Cobber mode is overwrite or append...') + + ! Check if the file exists + inquire(file=trim(stream % filename), exist=recordSeek) + end if + + ! + ! Build stream from pools of fields and attributes + ! + allocate(stream % stream) + call MPAS_createStream(stream % stream, stream % filename, MPAS_IO_PNETCDF, MPAS_IO_WRITE, & + precision=stream % precision, clobberRecords=clobberRecords, & + clobberFiles=clobberFiles, truncateFiles=truncateFiles, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + if (local_ierr == MPAS_STREAM_CLOBBER_FILE) then + ! + ! We should have only reached this point if clobber_mode = never_modify + ! + write(err_string,'(a)') 'Writing to stream '''//trim(stream % name)//''' would clobber file '''//& + trim(stream % filename)//''',' + STREAM_ERROR_WRITE(trim(err_string)) + write(err_string,'(a)') ' but clobber_mode is set to ''never_modify''.' + STREAM_ERROR_WRITE(trim(err_string)) + ierr = MPAS_STREAM_MGR_ERR_CLOBBER_FILE + else + ierr = MPAS_STREAM_MGR_ERROR + end if + return + end if + + ! File exists on disk, prior to creating stream. Need to seek the record to ensure we're writing to the correct place. + if ( recordSeek ) then + STREAM_DEBUG_WRITE(' -- File exists on disk: ' COMMA trim(stream % filename)) + now_time = mpas_get_clock_time(manager % streamClock, MPAS_NOW, ierr=local_ierr) + call mpas_get_time(now_time, dateTimeString=now_string) + + ! Look for exact record (in the case of overwriting) + ! This also gets the number of records in the file. + stream % nRecords = MPAS_seekStream(stream % stream, now_string, MPAS_STREAM_EXACT_TIME, actualWhen, maxRecords, local_ierr) + STREAM_DEBUG_WRITE(' -- Seeked record is: ' COMMA stream % nRecords COMMA ' with current records equal to ' COMMA maxRecords COMMA ' and an error of ' COMMA local_ierr) + + if ( stream % nRecords == 0 ) then + ! If we didn't find an exact time, set record to point to the end of the file. + ! This might result in non-monotonic timestamps in the output file. + stream % nRecords = maxRecords + 1 + STREAM_DEBUG_WRITE(' -- No exact time match found for ' COMMA trim(now_string) COMMA ' appending record instead.') + STREAM_DEBUG_WRITE(' -- Setting record to: ' COMMA stream % nRecords) + end if + end if + + call build_stream(stream, MPAS_STREAM_OUTPUT, manager % allFields, timeLevel, mgLevel, local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + stream % timeLevel = timeLevel + + stream % valid = .true. + else + if ( stream % filename_interval /= 'none' ) then + now_time = mpas_get_clock_time(manager % streamClock, MPAS_NOW, ierr=local_ierr) + call mpas_set_timeInterval(filename_interval, timeString=stream % filename_interval) + + call build_filename(stream % referenceTime, now_time, filename_interval, stream % filename_template, temp_filename, ierr=local_ierr) + else + call mpas_get_time(stream % referenceTime, dateTimeString=time_string) + call mpas_expand_string(time_string, stream % filename_template, temp_filename) + end if + + if (temp_filename /= stream % filename) then + + stream % filename = temp_filename + + ! + ! Close existing stream + ! + call MPAS_closeStream(stream % stream, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + recordSeek = .false. + ! Based on clobber_mode, determine if it matters if the file exists or not. + if ( stream % clobber_mode == MPAS_STREAM_CLOBBER_OVERWRITE .or. stream % clobber_mode == MPAS_STREAM_CLOBBER_APPEND ) then + STREAM_DEBUG_WRITE(' -- Cobber mode is overwrite or append...') + + ! Check if the file exists + inquire(file=trim(stream % filename), exist=recordSeek) + end if + + stream % nRecords = 1 + + ! + ! Build new stream from pools of fields and attributes + ! + call MPAS_createStream(stream % stream, stream % filename, MPAS_IO_PNETCDF, MPAS_IO_WRITE, & + precision=stream % precision, clobberRecords=clobberRecords, & + clobberFiles=clobberFiles, truncateFiles=truncateFiles, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + if (local_ierr == MPAS_STREAM_CLOBBER_FILE) then + ! + ! We should have only reached this point if clobber_mode = never_modify + ! + write(err_string,'(a)') 'Writing to stream '''//trim(stream % name)//''' would clobber file '''//& + trim(stream % filename)//''',' + STREAM_ERROR_WRITE(trim(err_string)) + write(err_string,'(a)') ' but clobber_mode is set to ''never_modify''.' + STREAM_ERROR_WRITE(trim(err_string)) + ierr = MPAS_STREAM_MGR_ERR_CLOBBER_FILE + else + ierr = MPAS_STREAM_MGR_ERROR + end if + stream % valid = .false. + return + end if + + ! File exists on disk, prior to creating stream. Need to seek the record to ensure we're writing to the correct place. + if ( recordSeek ) then + STREAM_DEBUG_WRITE(' -- File exists on disk: ' COMMA trim(stream % filename)) + now_time = mpas_get_clock_time(manager % streamClock, MPAS_NOW, ierr=local_ierr) + call mpas_get_time(now_time, dateTimeString=now_string) + + ! Look for exact record (in the case of overwriting) + ! This also gets the number of records in the file. + stream % nRecords = MPAS_seekStream(stream % stream, now_string, MPAS_STREAM_EXACT_TIME, actualWhen, maxRecords, local_ierr) + STREAM_DEBUG_WRITE(' -- Seeked record is: ' COMMA stream % nRecords COMMA ' with current records equal to ' COMMA maxRecords COMMA ' and an error of ' COMMA local_ierr) + + if ( stream % nRecords == 0 ) then + ! If we didn't find an exact time, set record to point to the end of the file. + ! This might result in non-monotonic timestamps in the output file. + stream % nRecords = maxRecords + 1 + STREAM_DEBUG_WRITE(' -- No exact time match found for ' COMMA trim(now_string) COMMA ' appending record instead.') + STREAM_DEBUG_WRITE(' -- Setting record to: ' COMMA stream % nRecords) + end if + end if + + call build_stream(stream, MPAS_STREAM_OUTPUT, manager % allFields, timeLevel, mgLevel, local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + stream % timeLevel = timeLevel + else + stream % nRecords = stream % nRecords + 1 + if ( stream % clobber_mode == MPAS_STREAM_CLOBBER_OVERWRITE .or. stream % clobber_mode == MPAS_STREAM_CLOBBER_APPEND ) then + now_time = mpas_get_clock_time(manager % streamClock, MPAS_NOW, ierr=local_ierr) + call mpas_get_time(now_time, dateTimeString=now_string) + + ! Look for exact record (in the case of overwriting) + ! This also gets the number of records in the file. + tempRecord = MPAS_seekStream(stream % stream, now_string, MPAS_STREAM_EXACT_TIME, actualWhen, maxRecords, local_ierr) + STREAM_DEBUG_WRITE(' -- Seeked record is: ' COMMA tempRecord COMMA ' with current records equal to ' COMMA maxRecords COMMA ' and an error of ' COMMA local_ierr) + + if ( tempRecord /= 0 .and. stream % nRecords < maxRecords ) then + ! If we found an exact result + ! This might result in non-monotonic timestamps in the output file. + swapRecords = .true. + maxRecords = stream % nRecords + stream % nRecords = tempRecord + tempRecord = maxRecords + STREAM_DEBUG_WRITE(' -- Exact time match found for ' COMMA trim(now_string) ) + STREAM_DEBUG_WRITE(' -- Setting record to: ' COMMA stream % nRecords) + else if ( tempRecord == 0 .and. stream % nRecords < maxRecords ) then + ! If we didn't find an exact time, set record to point to the end of the file. + ! This might result in non-monotonic timestamps in the output file. + stream % nRecords = maxRecords + 1 + STREAM_DEBUG_WRITE(' -- No exact time match found for ' COMMA trim(now_string) COMMA ' appending record instead.') + STREAM_DEBUG_WRITE(' -- Setting record to: ' COMMA stream % nRecords) + end if + end if + end if + end if + + if (timeLevel /= stream % timeLevel) then + + call update_stream(stream, manager % allFields, timeLevel, mgLevel, local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + stream % timeLevel = timeLevel + end if + + ! + ! For any connectivity arrays in the stream, temporarily convert local indices to global indices + ! + call prewrite_reindex(manager % allFields, stream % field_pool) + + ! + ! Write the stream + ! + STREAM_DEBUG_WRITE(' -- Writing stream ' COMMA trim(stream % name)) + call MPAS_writeStream(stream % stream, stream % nRecords, ierr=local_ierr) + + ! + ! Regardless of the error code from MPAS_writeStream, we need to reset global indices in the stream back to local indices + ! + call postwrite_reindex(manager % allFields, stream % field_pool) + + if (local_ierr /= MPAS_STREAM_NOERR) then + if (local_ierr == MPAS_STREAM_CLOBBER_RECORD) then + ! + ! We should have only reached this point if clobber_mode = append + ! + write(err_string,'(a,i4,a)') 'Writing to stream '''//trim(stream % name)//''' would overwrite record ', & + stream % nRecords, ' in file '''//trim(stream % filename)//''',' + STREAM_ERROR_WRITE(trim(err_string)) + write(err_string,'(a)') ' but clobber_mode is set to ''append''.' + STREAM_ERROR_WRITE(trim(err_string)) + ierr = MPAS_STREAM_MGR_ERR_CLOBBER_REC + else + ierr = MPAS_STREAM_MGR_ERROR + end if + + if ( swapRecords ) then + stream % nRecords = tempRecord + end if + return + end if + + if ( swapRecords ) then + stream % nRecords = tempRecord + end if + + end subroutine write_stream !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mgr_read + ! + !> \brief Read streams that are managed by an MPAS stream manager. + !> \author Michael Duda, Doug Jacobsen + !> \date 13 June 2014 + !> \details + !> With no optional arguments, reads all streams whose alarms are ringing. + !> The "streamID" argument optionally specifies the ID of a particular stream + !> to be read; if no other optional arguments are given, the specified stream + !> is only read if any of its alarms are ringing. + !> The "timeLevel" argument optionally specifies, for fields with multiple + !> time levels, the time level into which fields should be read. + !> The "mgLevel" argument optionally specifies, for fields that exist for + !> multiple grid levels, the grid level into which fields should be read. + !> The "when" argument optionally specifies the timestamp from which fields + !> are to be read. + !> The "whence" argument optionally specifies the method for determining + !> the timestamp to read from in case an exact match is not found for the + !> read timestamp, which is the current time unless the optional "when" + !> argument is given; possible values are MPAS_STREAM_EXACT_TIME, + !> MPAS_STREAM_NEAREST, MPAS_STREAM_LATEST_BEFORE, + !> MPAS_STREAM_LATEST_STRICTLY_BEFORE, MPAS_STREAM_EARLIEST_AFTER, or + !> MPAS_STREAM_EARLIEST_STRICTLY_AFTER. + !> The optional output argument "actualWhen" returns the actual time read + !> from a stream in case an exact match for the "when" time is not found, + !> and a nearby time is selected using the "whence" argument. + ! + !----------------------------------------------------------------------- + subroutine MPAS_stream_mgr_read(manager, streamID, timeLevel, mgLevel, rightNow, when, whence, actualWhen, ierr) !{{{ + + implicit none + + type (MPAS_streamManager_type), intent(inout) :: manager + character (len=*), intent(in), optional :: streamID + integer, intent(in), optional :: timeLevel + integer, intent(in), optional :: mgLevel + logical, intent(in), optional :: rightNow + character (len=*), intent(in), optional :: when + integer, intent(in), optional :: whence + character (len=*), intent(out), optional :: actualWhen + integer, intent(out), optional :: ierr + + type (MPAS_stream_list_type), pointer :: stream_cursor + integer :: local_timeLevel + integer :: local_mgLevel + logical :: local_rightNow + character (len=StrKIND) :: local_when + integer :: local_whence + integer :: local_ierr + integer :: temp_ierr + type (MPAS_Time_type) :: now_time + + + STREAM_DEBUG_WRITE('-- Called MPAS_stream_mgr_read()') + + if (present(ierr)) ierr = MPAS_STREAM_MGR_NOERR + if (present(actualWhen)) write(actualWhen,'(a)') '0000-01-01_00:00:00' + + ! + ! Use optional arguments or set defaults + ! + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + if (present(mgLevel)) then + local_mgLevel = mgLevel + else + local_mgLevel = 1 + end if + + if (present(rightNow)) then + local_rightNow = rightNow + else + local_rightNow = .false. + end if + + if (present(when)) then + local_when = when + else + now_time = mpas_get_clock_time(manager % streamClock, MPAS_NOW, ierr=local_ierr) + call mpas_get_time(now_time, dateTimeString=local_when) + end if + + if (present(whence)) then + local_whence = whence + else + local_whence = MPAS_STREAM_EXACT_TIME + end if + + + ! + ! If a stream is specified, we process just that stream; otherwise, + ! process all streams + ! + if (present(streamID)) then + nullify(stream_cursor) + if (MPAS_stream_list_query(manager % streams, streamID, stream_cursor, ierr=ierr)) then + STREAM_DEBUG_WRITE('-- Handling read of stream '//trim(stream_cursor % name)) + + ! Verify that the stream is an input stream + if (stream_cursor % direction /= MPAS_STREAM_INPUT .and. stream_cursor % direction /= MPAS_STREAM_INPUT_OUTPUT) then + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' is not an input stream.') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + + call read_stream(manager, stream_cursor, local_timeLevel, local_mgLevel, local_rightNow, local_when, local_whence, & + actualWhen, local_ierr) + else + STREAM_ERROR_WRITE('Stream '//trim(streamID)//' does not exist in call to MPAS_stream_mgr_read().') + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + return + end if + else + nullify(stream_cursor) + stream_cursor => manager % streams % head + do while (associated(stream_cursor)) + STREAM_DEBUG_WRITE('-- Handling read of stream '//trim(stream_cursor % name)) + + ! Verify that the stream is an input stream + if (stream_cursor % direction == MPAS_STREAM_INPUT .or. & + stream_cursor % direction /= MPAS_STREAM_INPUT_OUTPUT) then + + ! + ! What should be the meaning of actualWhen if we read multiple streams in this call? + ! + call read_stream(manager, stream_cursor, local_timeLevel, local_mgLevel, local_rightNow, & + local_when, local_whence, actualWhen, temp_ierr) + if (temp_ierr /= MPAS_STREAM_MGR_NOERR) then + local_ierr = MPAS_STREAM_MGR_ERROR + end if + end if + + stream_cursor => stream_cursor % next + end do + end if + + if (present(ierr)) ierr = local_ierr + + end subroutine MPAS_stream_mgr_read !}}} + + + !----------------------------------------------------------------------- + ! routine read_stream + ! + !> \brief Handle the reading of a stream pointed to by the stream list node + !> \author Michael Duda, Doug Jacobsen + !> \date 4 September 2014 + !> \details + !> Private subroutine to handle the details of actually reading a stream. + ! + !----------------------------------------------------------------------- + subroutine read_stream(manager, stream, timeLevel, mgLevel, forceReadNow, when, whence, actualWhen, ierr) !{{{ + + implicit none + + type (MPAS_streamManager_type), intent(inout) :: manager + type (MPAS_stream_list_type), intent(inout) :: stream + integer, intent(in) :: timeLevel + integer, intent(in) :: mgLevel + logical, intent(in) :: forceReadNow + character (len=*), intent(in) :: when + integer, intent(in) :: whence + character (len=*), intent(out), optional :: actualWhen + integer, intent(out) :: ierr + + type (MPAS_stream_list_type), pointer :: alarm_cursor + type (MPAS_Time_type) :: now_time, ref_time, temp_time + type (MPAS_TimeInterval_type) :: temp_interval + type (MPAS_TimeInterval_type) :: filename_interval + character (len=StrKIND) :: temp_filename + character (len=StrKIND) :: temp_actualWhen + logical :: ringing_alarm + integer :: temp_maxRecords + integer :: local_ierr + + type (MPAS_Time_Type) :: currentTime, filenameTime + type (MPAS_TimeInterval_Type) :: filenameInterval + type (MPAS_Time_Type) :: whenTime, firstTime, secondTime + type (MPAS_TimeInterval_Type) :: firstDiff, secondDiff + + type (MPAS_Stream_type) :: testStream + character (len=StrKIND) :: test_when + character (len=StrKIND) :: test_filename + character (len=StrKIND) :: test_actualWhen + integer :: test_record, test_maxRecords + logical :: retestFile, rebuildStream + + + ierr = MPAS_STREAM_MGR_NOERR + rebuildStream = .false. + + ! + ! Check whether this stream is active + ! + if (.not. stream % active_stream) then + STREAM_DEBUG_WRITE('-- Stream '//trim(stream % name)//' is not currently active and will not be read.') + return + end if + + ! + ! Check whether all packages for this stream are inactive + ! Note: if the stream has no packages, it is assumed to be active + ! + if (.not. stream_active_pkg_check(stream)) then + STREAM_DEBUG_WRITE('-- Stream '//trim(stream % name)//' has only inactive packages and will not be read.') + return + end if + + ! + ! Check whether any of the input alarms for the stream are ringing + ! + ringing_alarm = .false. + alarm_cursor => stream % alarmList_in % head + do while (associated(alarm_cursor)) + if (mpas_is_alarm_ringing(manager % streamClock, alarm_cursor % name, ierr=local_ierr)) then + ringing_alarm = .true. + exit + end if + alarm_cursor => alarm_cursor % next + end do + + if ((.not. ringing_alarm) .and. (.not. forceReadNow)) then + return + end if + + ! + ! First we need to build the filename for the current read time. + ! + if ( stream % filename_interval /= 'none' ) then + call mpas_set_time(now_time, dateTimeString=when, ierr=local_ierr) + call mpas_set_timeInterval(filename_interval, timeString=stream % filename_interval) + + call build_filename(stream % referenceTime, now_time, filename_interval, stream % filename_template, temp_filename, ierr=local_ierr) + else + call mpas_expand_string(when, stream % filename_template, temp_filename) + end if + + STREAM_DEBUG_WRITE(' -- Stream filename is: ' COMMA trim(temp_filename) ) + + ! + ! If the stream is not valid, assume that we have not yet written this + ! stream, in which case we create the stream from scratch + ! + if (.not. stream % valid) then + stream % filename = temp_filename + + ! + ! Build stream from pools of fields and attributes + ! + allocate(stream % stream) + call MPAS_createStream(stream % stream, stream % filename, MPAS_IO_PNETCDF, MPAS_IO_READ, & + precision=stream % precision, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + call build_stream(stream, MPAS_STREAM_INPUT, manager % allFields, timeLevel, mgLevel, local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + stream % timeLevel = timeLevel + + stream % valid = .true. + else if (temp_filename /= stream % filename) then + STREAM_DEBUG_WRITE('-- Changing filename from '//trim(stream % filename)//' to '//trim(temp_filename)) + + stream % filename = temp_filename + + ! + ! Close existing stream + ! + call MPAS_closeStream(stream % stream, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Build new stream from pools of fields and attributes + ! + call MPAS_createStream(stream % stream, stream % filename, MPAS_IO_PNETCDF, MPAS_IO_READ, precision=stream % precision, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + call build_stream(stream, MPAS_STREAM_INPUT, manager % allFields, timeLevel, mgLevel, local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + stream % timeLevel = timeLevel + end if + + STREAM_DEBUG_WRITE(' Seeking time of ' COMMA trim(when)) + + ! + ! With multiple times per file, we need to get the record number from MPAS_seekStream. + ! + stream % nRecords = MPAS_seekStream(stream % stream, when, whence, temp_actualWhen, maxRecords=temp_maxRecords, ierr=local_ierr) + + if ( stream % nRecords == 0 .and. temp_maxRecords == 0 ) then + stream % nRecords = 1 + STREAM_WARNING_WRITE('File ' COMMA trim(stream % filename) COMMA ' does not contain a seekable xtime variable. Forcing a read of the first time record.') + else if (stream % nRecords /= 0) then + STREAM_DEBUG_WRITE(' Seeked record is: ' COMMA stream % nRecords COMMA ' out of ' COMMA temp_maxRecords COMMA ' with a time stamp of ' COMMA trim(temp_actualWhen) COMMA ' filename was ' COMMA trim(stream % filename)) + else if (temp_maxRecords /= 0 .and. whence == MPAS_STREAM_EXACT_TIME) then + STREAM_ERROR_WRITE('File ' COMMA trim(stream % filename) COMMA ' does not contain the time ' COMMA trim(when)) + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + retestFile = .false. + if ( trim(stream % filename_interval) /= 'none' .and. whence /= MPAS_STREAM_EXACT_TIME ) then + currentTime = mpas_get_clock_time(manager % streamClock, MPAS_NOW, ierr=local_ierr) + call mpas_set_timeInterval(filenameInterval, timeString=stream % filename_interval, ierr=local_ierr) + + ! Need to handle the case where the time requested was not found. + ! + ! Things that need to be handled here are when we're at the beginning + ! or end of a file and we're looking for the next or previous time + ! record. + ! + ! Currently this only checks one file each direction (forward or + ! backward). It will fail finding a file more than one interval away + ! from when. + if ( stream % nRecords == 0) then + if ( ( whence == MPAS_STREAM_LATEST_BEFORE .and. temp_actualWhen /= when ) .or. whence == MPAS_STREAM_LATEST_STRICTLY_BEFORE ) then + ! Subtract filename_interval from when, build new filename, and + ! check for a time latest before in that file. + filenameTime = currentTime - filenameInterval + retestFile = .true. + STREAM_DEBUG_WRITE(' Retest latest before...') + else if ( ( whence == MPAS_STREAM_EARLIEST_AFTER .and. temp_actualWhen /= when ).or. whence == MPAS_STREAM_EARLIEST_STRICTLY_AFTER ) then + ! Add filename_interval from when, build new filename, and + ! check for a time latest before in that file. + filenameTime = currentTime + filenameInterval + retestFile = .true. + STREAM_DEBUG_WRITE(' Retest earliest after...') + end if + else + ! If time was found, and we were looking for nearest need to make sure nearest isn't in previous or next file. + ! + ! This only needs to be checked if we found the first or last time slice in the file. + if ( whence == MPAS_STREAM_NEAREST ) then + if ( stream % nRecords == 1 .and. stream % nRecords == temp_maxRecords ) then + call mpas_set_time(temp_time, dateTimeString=temp_actualWhen) + + ! If an exact time was found, read that one, and don't bother re-testing. + if ( currentTime == temp_time ) then + retestFile = .false. + + ! If current time is before the time that was read, re-test using the previous file + else if ( currentTime < temp_time ) then + filenameTime = currentTime - filenameInterval + retestFile = .true. + STREAM_DEBUG_WRITE('Retest nearest prev file') + + ! If current time is before the time that was read, re-test using the next file + else if ( currentTime > temp_time ) then + filenameTime = currentTime + filenameInterval + retestFile = .true. + STREAM_DEBUG_WRITE('Retest nearest next file') + end if + else if ( stream % nRecords == 1 ) then + ! Subtract filename_interval from when, build new filename, and check for nearest time in that file. + ! Compare the two, and keep the one closest to when. + filenameTime = currentTime - filenameInterval + retestFile = .true. + STREAM_DEBUG_WRITE('Retest nearest beginning') + else if ( stream % nRecords == temp_maxRecords ) then + ! Add filename_interval from when, build new filename, and check for nearest time in that file. + ! Compare the two, and keep the one closest to when. + filenameTime = currentTime + filenameInterval + retestFile = .true. + STREAM_DEBUG_WRITE('Retest nearest end') + end if + end if + end if + end if + + if ( retestFile ) then + STREAM_DEBUG_WRITE(' --- Retesting file... ') + call mpas_get_time(filenameTime, dateTimeString=test_when) + + call mpas_set_timeInterval(filename_interval, timeString=stream % filename_interval) + + call build_filename(stream % referenceTime, filenameTime, filename_interval, stream % filename_template, test_filename, ierr=local_ierr) + + STREAM_DEBUG_WRITE(' --- Retesting filename is ' COMMA trim(test_filename)) + + inquire(file=trim(test_filename), exist=retestFile) + + ! If file exists, the testing stream needs to be built. + if ( retestFile ) then + call mpas_createStream(testStream, test_filename, MPAS_IO_PNETCDF, MPAS_IO_READ, precision=stream % precision, ierr=local_ierr) + else + STREAM_DEBUG_WRITE(' Filename: ' COMMA trim(test_filename) COMMA ' does not exist.') + end if + end if + + ! Only continue testing file it if was found. + if ( retestFile ) then + test_record = MPAS_seekStream(testStream, when, whence, test_actualWhen, maxRecords=test_maxRecords, ierr=local_ierr) + + STREAM_DEBUG_WRITE(' -- Test record is ' COMMA test_record COMMA ' out of ' COMMA test_maxRecords COMMA ' with a time of ' COMMA trim(test_actualWhen)) + + if ( test_record /= 0 ) then + if ( whence == MPAS_STREAM_NEAREST ) then + call mpas_set_time(whenTime, dateTimeString=when) + call mpas_set_time(firstTime, dateTimeString=temp_actualWhen) + call mpas_set_time(secondTime, dateTimeString=test_actualWhen) + + ! Build first diff + if ( firstTime > whenTime ) then + firstDiff = firstTime - whenTime + else + firstDiff = whenTime - firstTime + end if + + ! Build second diff + if ( secondTime > whenTime ) then + secondDiff = secondTime - whenTime + else + secondDiff = whenTime - secondTime + end if + + ! Compare first and second diff, keeping the closest one to when. + ! Only need to rebuild stream if the second* ones are closer. + if ( secondDiff == firstDiff ) then + + ! If times are equidistance, take the later of the two. + if ( firstTime > secondTime ) then + rebuildStream = .false. + else + rebuildStream = .true. + end if + else if ( secondDiff < firstDiff ) then + rebuildStream = .true. + STREAM_DEBUG_WRITE(' --- New time is closer than old time') + else + STREAM_DEBUG_WRITE(' --- Old time is closer than test time') + end if + else if ( stream % nRecords == 0 ) then + rebuildStream = .true. + end if + else + rebuildStream = .false. + end if + call MPAS_closeStream(testStream, ierr=local_ierr) + end if + + ! Rebuild stream if we need to, because a different file has a closer time. + if ( rebuildStream ) then + STREAM_DEBUG_WRITE(' --- rebuilding stream...') + stream % filename = test_filename + + ! + ! Close existing stream + ! + call MPAS_closeStream(stream % stream, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + ! + ! Build new stream from pools of fields and attributes + ! + call MPAS_createStream(stream % stream, stream % filename, MPAS_IO_PNETCDF, MPAS_IO_READ, precision=stream % precision, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + call build_stream(stream, MPAS_STREAM_INPUT, manager % allFields, timeLevel, mgLevel, local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + stream % timeLevel = timeLevel + + ! Set record number based on test_record from the read we just did. + stream % nRecords = test_record + end if + + if (timeLevel /= stream % timeLevel) then + + call update_stream(stream, manager % allFields, timeLevel, mgLevel, local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + stream % timeLevel = timeLevel + end if + + ! + ! Read the stream + ! + call MPAS_readStream(stream % stream, stream % nRecords, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + if (present(actualWhen)) then + call MPAS_streamTime(stream % stream, stream % nRecords, actualWhen, ierr=local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then +! +! TODO: Add debug prints for all error conditions +! + ierr = MPAS_STREAM_MGR_ERROR + return + end if + end if + + ! + ! Exchange halos for all decomposed fields in this stream + ! + call exch_all_halos(manager % allFields, stream % field_pool, stream % timeLevel, local_ierr) + + ! + ! For any connectivity arrays in this stream, convert global indices to local indices + ! + call postread_reindex(manager % allFields, stream % field_pool) + + end subroutine read_stream !}}} + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_mesg + ! + !> \brief Write an error message (if the level requires it) to + !> \author Michael Duda, Doug Jacobsen + !> \date 07/16/2014 + !> \details Using the input error level, + !----------------------------------------------------------------------- + subroutine MPAS_stream_mesg(level, mesg)!{{{ + + use mpas_dmpar + + implicit none + + integer, intent(in) :: level + character(len=*), intent(in) :: mesg + + if (level /= MPAS_STREAM_ERR_SILENT) then + write(stderrUnit, *) trim(mesg) + if (level == MPAS_STREAM_ERR_FATAL) then + call mpas_dmpar_global_abort(mesg) + end if + end if + + end subroutine MPAS_stream_mesg!}}} + + + !----------------------------------------------------------------------- + ! routine build_filename + ! + !> \brief Construct the filename that contains a specific time in a stream + !> \author Michael Duda, Doug Jacobsen + !> \date 21 August 2014 + !> \details + !> Given a filename template and the information necessary to determine the time + !> in the stream that matches a time available in any of the files associated with + !> the stream, returns a specific filename that should contain that time. + !> + !> Filenames are assumed to start at the earliest time. In other words, a + !> file name is expanded using the earliest time that could possibly be + !> stored in the file. + !> + !> Return error codes: + !> 0 no error + !----------------------------------------------------------------------- + subroutine build_filename(ref_time, when, filename_interval, filename_template, filename, ierr) !{{{ + + implicit none + + type (MPAS_Time_type), intent(in) :: ref_time + type (MPAS_Time_type), intent(in) :: when + type (MPAS_TimeInterval_type), intent(in) :: filename_interval + character(len=*), intent(in) :: filename_template + character(len=*), intent(out) :: filename + integer, intent(out) :: ierr + + character(len=StrKIND) :: temp_string + character(len=StrKIND) :: when_string + type (MPAS_Time_type) :: filetime + type (MPAS_TimeInterval_type) :: intv, rem, zeroIntv + integer :: nrecs, nfiles, irec, direction + logical :: in_future + + STREAM_DEBUG_WRITE(' ** Building Filename') + + ierr = 0 + + ! If current time (when) is further ahead than ref_time + ! the interval we want is when - ref_time (time between now and the reference time) + if ( when >= ref_time ) then + intv = when - ref_time + direction = 1 + else + intv = ref_time - when + direction = -1 + end if + +! call mpas_get_time(when, dateTimeString=temp_string) + STREAM_DEBUG_WRITE(' ** when is: ' COMMA trim(temp_string)) + +! call mpas_get_time(ref_time, dateTimeString=temp_string) + STREAM_DEBUG_WRITE(' ** ref_time is: ' COMMA trim(temp_string)) + +! call mpas_get_timeInterval(intv, timeString=temp_string) + STREAM_DEBUG_WRITE(' ** intv is: ' COMMA trim(temp_string)) + + call mpas_interval_division(ref_time, intv, filename_interval, nrecs, rem) + +! STREAM_DEBUG_WRITE(' ** Divisions are: ' COMMA nrecs) + + call mpas_set_timeInterval(zeroIntv, s=0) + + if ( rem /= zeroIntv ) then + ! direction == 1 means when is later than ref_time + if (direction == 1) then + filetime = when - rem + else + filetime = when + rem + filetime = filetime - filename_interval + end if + else + filetime = when + end if + call mpas_get_time(filetime, dateTimeString=when_string) + STREAM_DEBUG_WRITE(' ** filetime start is: ' COMMA trim(when_string)) + + call mpas_expand_string(when_string, filename_template, filename) + + end subroutine build_filename !}}} + + + !----------------------------------------------------------------------- + ! routine build_stream + ! + !> \brief This is a utility routine to build a stream type from a pool representing a stream. + !> \author Michael Duda, Doug Jacobsen + !> \date 07/23/2014 + !> \details + !> This routine will take as input a pool representing a stream. + !> It will then generate a stream type based on this pool, and return that. + !----------------------------------------------------------------------- + subroutine build_stream(stream, direction, allFields, timeLevelIn, mgLevelIn, ierr) !{{{ + + implicit none + + type (MPAS_stream_list_type), intent(inout) :: stream + integer, intent(in) :: direction + type (MPAS_Pool_type), intent(in) :: allFields + integer, intent(in) :: timeLevelIn + integer, intent(in) :: mgLevelIn + integer, intent(out) :: ierr + + type (MPAS_Pool_iterator_type) :: itr + type (mpas_pool_field_info_type) :: info + integer :: timeLevel + + type (field5DReal), pointer :: real5d + type (field4DReal), pointer :: real4d + type (field3DReal), pointer :: real3d + type (field2DReal), pointer :: real2d + type (field1DReal), pointer :: real1d + type (field0DReal), pointer :: real0d + + type (field3DInteger), pointer :: int3d + type (field2DInteger), pointer :: int2d + type (field1DInteger), pointer :: int1d + type (field0DInteger), pointer :: int0d + + type (field1DChar), pointer :: char1d + type (field0DChar), pointer :: char0d + + integer, pointer :: intAtt + logical, pointer :: logAtt + character (len=StrKIND), pointer :: charAtt + real (kind=RKIND), pointer :: realAtt + + integer :: local_ierr + + integer, parameter :: idLength = 10 + character (len=idLength) :: file_id + + + if (direction == MPAS_STREAM_OUTPUT) then + + ! + ! Write attributes to stream + ! + call mpas_pool_begin_iteration(stream % att_pool) + do while (mpas_pool_get_next_member(stream % att_pool, itr)) + if ( itr % memberType == MPAS_POOL_CONFIG) then + if ( itr % dataType == MPAS_POOL_REAL ) then + call mpas_pool_get_config(stream % att_pool, itr % memberName, realAtt) + call mpas_writeStreamAtt(stream % stream, itr % memberName, realAtt, local_ierr) + else if ( itr % dataType == MPAS_POOL_INTEGER ) then + call mpas_pool_get_config(stream % att_pool, itr % memberName, intAtt) + call mpas_writeStreamAtt(stream % stream, itr % memberName, intAtt, local_ierr) + else if ( itr % dataType == MPAS_POOL_CHARACTER ) then + call mpas_pool_get_config(stream % att_pool, itr % memberName, charAtt) + call mpas_writeStreamAtt(stream % stream, itr % memberName, charAtt, local_ierr) + else if ( itr % dataType == MPAS_POOL_LOGICAL ) then + call mpas_pool_get_config(stream % att_pool, itr % memberName, logAtt) + if (logAtt) then + call mpas_writeStreamAtt(stream % stream, itr % memberName, 'YES', local_ierr) + else + call mpas_writeStreamAtt(stream % stream, itr % memberName, 'NO', local_ierr) + end if + end if + + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + end if + end do + + ! + ! Generate file_id and write to stream + ! + call gen_random(idLength, file_id) + call mpas_writeStreamAtt(stream % stream, 'file_id', file_id, local_ierr) + if (local_ierr /= MPAS_STREAM_NOERR) then + ierr = MPAS_STREAM_MGR_ERROR + return + end if + + end if + + + ierr = MPAS_STREAM_MGR_NOERR + + call mpas_pool_begin_iteration(stream % field_pool) + + do while ( mpas_pool_get_next_member(stream % field_pool, itr) ) + + if (itr % memberType == MPAS_POOL_CONFIG) then + + ! To avoid accidentally matching in case statements below... + info % fieldType = -1 + + call mpas_pool_get_field_info(allFields, itr % memberName, info) + + ! Set time level to read + if (info % nTimeLevels >= timeLevelIn) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + select case (info % fieldType) + case (MPAS_POOL_REAL) + select case (info % nDims) + case (0) + call mpas_pool_get_field(allFields, itr % memberName, real0d, timeLevel) + call MPAS_streamAddField(stream % stream, real0d) + case (1) + call mpas_pool_get_field(allFields, itr % memberName, real1d, timeLevel) + call MPAS_streamAddField(stream % stream, real1d) + case (2) + call mpas_pool_get_field(allFields, itr % memberName, real2d, timeLevel) + call MPAS_streamAddField(stream % stream, real2d) + case (3) + call mpas_pool_get_field(allFields, itr % memberName, real3d, timeLevel) + call MPAS_streamAddField(stream % stream, real3d) + case (4) + call mpas_pool_get_field(allFields, itr % memberName, real4d, timeLevel) + call MPAS_streamAddField(stream % stream, real4d) + case (5) + call mpas_pool_get_field(allFields, itr % memberName, real5d, timeLevel) + call MPAS_streamAddField(stream % stream, real5d) + end select + case (MPAS_POOL_INTEGER) + select case (info % nDims) + case (0) + call mpas_pool_get_field(allFields, itr % memberName, int0d, timeLevel) + call MPAS_streamAddField(stream % stream, int0d) + case (1) + call mpas_pool_get_field(allFields, itr % memberName, int1d, timeLevel) + call MPAS_streamAddField(stream % stream, int1d) + case (2) + call mpas_pool_get_field(allFields, itr % memberName, int2d, timeLevel) + call MPAS_streamAddField(stream % stream, int2d) + case (3) + call mpas_pool_get_field(allFields, itr % memberName, int3d, timeLevel) + call MPAS_streamAddField(stream % stream, int3d) + end select + case (MPAS_POOL_CHARACTER) + select case (info % nDims) + case (0) + call mpas_pool_get_field(allFields, itr % memberName, char0d, timeLevel) + call MPAS_streamAddField(stream % stream, char0d) + case (1) +! call mpas_pool_get_field(allFields, itr % memberName, char1d, timeLevel) +! call MPAS_streamAddField(stream % stream, char1d) + write(stderrUnit,*) 'Error: In build_stream, unsupported type field1DChar.' + end select + end select + + end if + end do + + end subroutine build_stream !}}} + + + !----------------------------------------------------------------------- + ! routine update_stream + ! + !> \brief Updates the time level for fields in a stream + !> \author Michael Duda, Doug Jacobsen + !> \date 07/23/2014 + !> \details + !> For an existing stream, updates the time levels for all fields in + !> the stream so that subsequent reads/writes of the stream will read + !> from / write to the specified time level. + !----------------------------------------------------------------------- + subroutine update_stream(stream, allFields, timeLevelIn, mgLevelIn, ierr) !{{{ + + implicit none + + type (MPAS_stream_list_type), intent(inout) :: stream + type (MPAS_Pool_type), intent(in) :: allFields + integer, intent(in) :: timeLevelIn + integer, intent(in) :: mgLevelIn + integer, intent(out) :: ierr + + type (MPAS_Pool_iterator_type) :: itr + type (mpas_pool_field_info_type) :: info + integer :: timeLevel + + type (field5DReal), pointer :: real5d + type (field4DReal), pointer :: real4d + type (field3DReal), pointer :: real3d + type (field2DReal), pointer :: real2d + type (field1DReal), pointer :: real1d + type (field0DReal), pointer :: real0d + + type (field3DInteger), pointer :: int3d + type (field2DInteger), pointer :: int2d + type (field1DInteger), pointer :: int1d + type (field0DInteger), pointer :: int0d + + type (field1DChar), pointer :: char1d + type (field0DChar), pointer :: char0d + + + ierr = MPAS_STREAM_MGR_NOERR + + call mpas_pool_begin_iteration(stream % field_pool) + + do while ( mpas_pool_get_next_member(stream % field_pool, itr) ) + + if (itr % memberType == MPAS_POOL_CONFIG) then + + ! To avoid accidentally matching in case statements below... + info % fieldType = -1 + + call mpas_pool_get_field_info(allFields, itr % memberName, info) + + ! Set time level to read + if (info % nTimeLevels >= timeLevelIn) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if + + select case (info % fieldType) + case (MPAS_POOL_REAL) + select case (info % nDims) + case (0) + call mpas_pool_get_field(allFields, itr % memberName, real0d, timeLevel) + call MPAS_streamUpdateField(stream % stream, real0d) + case (1) + call mpas_pool_get_field(allFields, itr % memberName, real1d, timeLevel) + call MPAS_streamUpdateField(stream % stream, real1d) + case (2) + call mpas_pool_get_field(allFields, itr % memberName, real2d, timeLevel) + call MPAS_streamUpdateField(stream % stream, real2d) + case (3) + call mpas_pool_get_field(allFields, itr % memberName, real3d, timeLevel) + call MPAS_streamUpdateField(stream % stream, real3d) + case (4) + call mpas_pool_get_field(allFields, itr % memberName, real4d, timeLevel) + call MPAS_streamUpdateField(stream % stream, real4d) + case (5) + call mpas_pool_get_field(allFields, itr % memberName, real5d, timeLevel) + call MPAS_streamUpdateField(stream % stream, real5d) + end select + case (MPAS_POOL_INTEGER) + select case (info % nDims) + case (0) + call mpas_pool_get_field(allFields, itr % memberName, int0d, timeLevel) + call MPAS_streamUpdateField(stream % stream, int0d) + case (1) + call mpas_pool_get_field(allFields, itr % memberName, int1d, timeLevel) + call MPAS_streamUpdateField(stream % stream, int1d) + case (2) + call mpas_pool_get_field(allFields, itr % memberName, int2d, timeLevel) + call MPAS_streamUpdateField(stream % stream, int2d) + case (3) + call mpas_pool_get_field(allFields, itr % memberName, int3d, timeLevel) + call MPAS_streamUpdateField(stream % stream, int3d) + end select + case (MPAS_POOL_CHARACTER) + select case (info % nDims) + case (0) + call mpas_pool_get_field(allFields, itr % memberName, char0d, timeLevel) + call MPAS_streamUpdateField(stream % stream, char0d) + case (1) +! call mpas_pool_get_field(allFields, itr % memberName, char1d, timeLevel) +! call MPAS_streamUpdateField(stream % stream, char1d) + write(stderrUnit,*) 'Error: In update_stream, unsupported type field1DChar.' + end select + end select + + end if + end do + + end subroutine update_stream !}}} + + + !----------------------------------------------------------------------- + ! routine stream_active_pkg_check + ! + !> \brief Checks whether a stream has any active packages (or none at all) + !> \author Michael Duda + !> \date 23 September 2014 + !> \details + !> This function determines whether a stream has any active packages + !> associated with it. If the stream has at least one active package, + !> or no packages at all, the function returns true; else, if all packages + !> associated with the package are inactive, the function returns false. + ! + !----------------------------------------------------------------------- + logical function stream_active_pkg_check(stream) !{{{ + + implicit none + + type (MPAS_stream_list_type), intent(inout) :: stream + + type (MPAS_Pool_iterator_type) :: itr + logical, pointer :: pkg_val + integer :: npkgs + + + stream_active_pkg_check = .false. + npkgs = 0 + call mpas_pool_begin_iteration(stream % pkg_pool) + + do while ( mpas_pool_get_next_member(stream % pkg_pool, itr) ) + if (itr % memberType == MPAS_POOL_PACKAGE) then + nullify(pkg_val) + call mpas_pool_get_package(stream % pkg_pool, trim(itr % memberName), pkg_val) + if (associated(pkg_val)) then + npkgs = npkgs + 1 + stream_active_pkg_check = stream_active_pkg_check .or. pkg_val + end if + else + ! This is unexpected... + STREAM_DEBUG_WRITE('... found non-package '//trim(itr % memberName)//' in package pool for stream '//trim(stream % name)) + end if + end do + + if (npkgs == 0) then + stream_active_pkg_check = .true. + end if + + end function stream_active_pkg_check !}}} + + + !----------------------------------------------------------------------- + ! routine exch_all_halos + ! + !> \brief Exchange halos of all fields in stream + !> \author Doug Jacobsen, Michael Duda + !> \date 09/12/2014 + !> \details + !> This routine performs a halo exchange of each decomposed field within a stream. + ! + !----------------------------------------------------------------------- + subroutine exch_all_halos(allFields, streamFields, timeLevel, ierr) !{{{ + + implicit none + + type (mpas_pool_type), pointer :: allFields + type (mpas_pool_type), pointer :: streamFields + integer, intent(in) :: timeLevel + integer, intent(out) :: ierr + + type (mpas_pool_iterator_type) :: fieldItr + type (mpas_pool_field_info_type) :: fieldInfo + + type (field1DReal), pointer :: real1DField + type (field2DReal), pointer :: real2DField + type (field3DReal), pointer :: real3DField + type (field4DReal), pointer :: real4DField + type (field5DReal), pointer :: real5DField + type (field1DInteger), pointer :: int1DField + type (field2DInteger), pointer :: int2DField + type (field3DInteger), pointer :: int3DField + + + ierr = MPAS_STREAM_MGR_NOERR + + call mpas_pool_begin_iteration(streamFields) + + do while ( mpas_pool_get_next_member(streamFields, fieldItr) ) + + ! Note: in a stream's field_pool, the names of fields are stored as configs + if ( fieldItr % memberType == MPAS_POOL_CONFIG ) then + + call mpas_pool_get_field_info(allFields, fieldItr % memberName, fieldInfo) + + if ( fieldInfo % nDims == 1) then + if ( fieldInfo % fieldType == MPAS_POOL_REAL ) then + if ( timeLevel <= fieldInfo % nTimeLevels ) then + call mpas_pool_get_field(allFields, fieldItr % memberName, real1DField, timeLevel) + else + call mpas_pool_get_field(allFields, fieldItr % memberName, real1DField, 1) + end if + + if ( is_decomposed_dim(real1DField % dimNames(1))) then + STREAM_DEBUG_WRITE(' -- Exchange halo for '//trim(fieldItr % memberName)) + call mpas_dmpar_exch_halo_field(real1DField) + end if + else if ( fieldInfo % fieldType == MPAS_POOL_INTEGER ) then + if ( timeLevel <= fieldInfo % nTimeLevels ) then + call mpas_pool_get_field(allFields, fieldItr % memberName, int1DField, timeLevel) + else + call mpas_pool_get_field(allFields, fieldItr % memberName, int1DField, 1) + end if + if ( is_decomposed_dim(int1DField % dimNames(1))) then + STREAM_DEBUG_WRITE(' -- Exchange halo for '//trim(fieldItr % memberName)) + call mpas_dmpar_exch_halo_field(int1DField) + end if + end if + + else if ( fieldInfo % nDims == 2) then + if ( fieldInfo % fieldType == MPAS_POOL_REAL ) then + if ( timeLevel <= fieldInfo % nTimeLevels ) then + call mpas_pool_get_field(allFields, fieldItr % memberName, real2DField, timeLevel) + else + call mpas_pool_get_field(allFields, fieldItr % memberName, real2DField, 1) + end if + if ( is_decomposed_dim(real2DField % dimNames(2))) then + STREAM_DEBUG_WRITE(' -- Exchange halo for '//trim(fieldItr % memberName)) + call mpas_dmpar_exch_halo_field(real2DField) + end if + else if ( fieldInfo % fieldType == MPAS_POOL_INTEGER ) then + if ( timeLevel <= fieldInfo % nTimeLevels ) then + call mpas_pool_get_field(allFields, fieldItr % memberName, int2DField, timeLevel) + else + call mpas_pool_get_field(allFields, fieldItr % memberName, int2DField, 1) + end if + if ( is_decomposed_dim(int2DField % dimNames(2))) then + STREAM_DEBUG_WRITE(' -- Exchange halo for '//trim(fieldItr % memberName)) + call mpas_dmpar_exch_halo_field(int2DField) + end if + end if + + else if ( fieldInfo % nDims == 3) then + if ( fieldInfo % fieldType == MPAS_POOL_REAL ) then + if ( timeLevel <= fieldInfo % nTimeLevels ) then + call mpas_pool_get_field(allFields, fieldItr % memberName, real3DField, timeLevel) + else + call mpas_pool_get_field(allFields, fieldItr % memberName, real3DField, 1) + end if + if ( is_decomposed_dim(real3DField % dimNames(3))) then + STREAM_DEBUG_WRITE(' -- Exchange halo for '//trim(fieldItr % memberName)) + call mpas_dmpar_exch_halo_field(real3DField) + end if + else if ( fieldInfo % fieldType == MPAS_POOL_INTEGER ) then + if ( timeLevel <= fieldInfo % nTimeLevels ) then + call mpas_pool_get_field(allFields, fieldItr % memberName, int3DField, timeLevel) + else + call mpas_pool_get_field(allFields, fieldItr % memberName, int3DField, 1) + end if + if ( is_decomposed_dim(int3DField % dimNames(3))) then + STREAM_DEBUG_WRITE(' -- Exchange halo for '//trim(fieldItr % memberName)) + call mpas_dmpar_exch_halo_field(int3DField) + end if + end if + + else if ( fieldInfo % nDims == 4) then + if ( fieldInfo % fieldType == MPAS_POOL_REAL ) then + if ( timeLevel <= fieldInfo % nTimeLevels ) then + call mpas_pool_get_field(allFields, fieldItr % memberName, real4DField, timeLevel) + else + call mpas_pool_get_field(allFields, fieldItr % memberName, real4DField, 1) + end if + if ( is_decomposed_dim(real4DField % dimNames(4))) then + STREAM_DEBUG_WRITE(' -- Exchange halo for '//trim(fieldItr % memberName)) + call mpas_dmpar_exch_halo_field(real4DField) + end if + end if + + else if ( fieldInfo % nDims == 5) then + if ( fieldInfo % fieldType == MPAS_POOL_REAL ) then + if ( timeLevel <= fieldInfo % nTimeLevels ) then + call mpas_pool_get_field(allFields, fieldItr % memberName, real5DField, timeLevel) + else + call mpas_pool_get_field(allFields, fieldItr % memberName, real5DField, 1) + end if + if ( is_decomposed_dim(real5DField % dimNames(5))) then + STREAM_DEBUG_WRITE(' -- Exchange halo for '//trim(fieldItr % memberName)) + call mpas_dmpar_exch_halo_field(real5DField) + end if + end if + end if + + end if + + end do + + end subroutine exch_all_halos !}}} + + + !----------------------------------------------------------------------- + ! routine is_decomposed_dim + ! + !> \brief Determines whether a dimension represents a decomposed dimension or not + !> \author Michael Duda + !> \date 24 September 2014 + !> \details + !> This function determines whether the name of the input argument is + !> a decompsed dimension or not. Currently in MPAS, the only decomposed + !> dimensions are: + !> nCells + !> nEdges + !> nVertices + ! + !----------------------------------------------------------------------- + logical function is_decomposed_dim(dimName) !{{{ + + implicit none + + character(len=*), intent(in) :: dimName + + if (trim(dimName) == 'nCells' .or. & + trim(dimName) == 'nEdges' .or. & + trim(dimName) == 'nVertices') then + + is_decomposed_dim = .true. + + else + + is_decomposed_dim = .false. + + end if + + end function is_decomposed_dim !}}} + + + !----------------------------------------------------------------------- + ! routine prewrite_reindex + ! + !> \brief Reindex connectivity fields from local to global index space. + !> \author Doug Jacobsen, Michael Duda + !> \date 24 September 2014 + !> \details + !> For any connectivity fields contained in the stream to be written, + !> whose fields include those in the streamFields pool, save the locally + !> indexed fields in module variables *_save, and allocate new arrays for + !> the fields, which are set to contain global indices. + !> This routine should be called immediately before a write of a stream. + ! + !----------------------------------------------------------------------- + subroutine prewrite_reindex(allFields, streamFields) !{{{ + + implicit none + + type (mpas_pool_type), pointer :: allFields + type (mpas_pool_type), pointer :: streamFields + + type (mpas_pool_iterator_type) :: fieldItr + type (mpas_pool_field_info_type) :: fieldInfo + + integer, pointer :: nCells, nEdges, nVertices, vertexDegree + integer, pointer :: maxEdges, maxEdges2, nEdgesSolve, nCellsSolve, nVerticesSolve + + type (field1dInteger), pointer :: nEdgesOnCell, nEdgesOnEdge, indexToCellID, indexToEdgeID, indexToVertexID + + type (field2dInteger), pointer :: cellsOnCell_ptr, edgesOnCell_ptr, verticesOnCell_ptr, & + cellsOnEdge_ptr, verticesOnEdge_ptr, edgesOnEdge_ptr, & + cellsOnVertex_ptr, edgesOnVertex_ptr + + type (field2dInteger), pointer :: cellsOnCell, edgesOnCell, verticesOnCell, & + cellsOnEdge, verticesOnEdge, edgesOnEdge, & + cellsOnVertex, edgesOnVertex + + logical :: handle_cellsOnCell, handle_edgesOnCell, handle_verticesOnCell, handle_cellsOnEdge, handle_verticesOnEdge, & + handle_edgesOnEdge, handle_cellsOnVertex, handle_edgesOnVertex + + integer :: i, j + + + nullify(cellsOnCell_save) + nullify(edgesOnCell_save) + nullify(verticesOnCell_save) + nullify(cellsOnEdge_save) + nullify(verticesOnEdge_save) + nullify(edgesOnEdge_save) + nullify(cellsOnVertex_save) + nullify(edgesOnVertex_save) + + nullify(cellsOnCell) + nullify(edgesOnCell) + nullify(verticesOnCell) + nullify(cellsOnEdge) + nullify(verticesOnEdge) + nullify(edgesOnEdge) + nullify(cellsOnVertex) + nullify(edgesOnVertex) + + ! + ! Determine which connectivity fields exist in this stream + ! + call mpas_pool_begin_iteration(streamFields) + do while ( mpas_pool_get_next_member(streamFields, fieldItr) ) + + ! Note: in a stream's field_pool, the names of fields are stored as configs + if ( fieldItr % memberType == MPAS_POOL_CONFIG ) then + call mpas_pool_get_field_info(allFields, fieldItr % memberName, fieldInfo) + + if (trim(fieldItr % memberName) == 'cellsOnCell') then + allocate(cellsOnCell_save) + cellsOnCell_ptr => cellsOnCell_save + call mpas_pool_get_field(allFields, 'cellsOnCell', cellsOnCell) + else if (trim(fieldItr % memberName) == 'edgesOnCell') then + allocate(edgesOnCell_save) + edgesOnCell_ptr => edgesOnCell_save + call mpas_pool_get_field(allFields, 'edgesOnCell', edgesOnCell) + else if (trim(fieldItr % memberName) == 'verticesOnCell') then + allocate(verticesOnCell_save) + verticesOnCell_ptr => verticesOnCell_save + call mpas_pool_get_field(allFields, 'verticesOnCell', verticesOnCell) + else if (trim(fieldItr % memberName) == 'cellsOnEdge') then + allocate(cellsOnEdge_save) + cellsOnEdge_ptr => cellsOnEdge_save + call mpas_pool_get_field(allFields, 'cellsOnEdge', cellsOnEdge) + else if (trim(fieldItr % memberName) == 'verticesOnEdge') then + allocate(verticesOnEdge_save) + verticesOnEdge_ptr => verticesOnEdge_save + call mpas_pool_get_field(allFields, 'verticesOnEdge', verticesOnEdge) + else if (trim(fieldItr % memberName) == 'edgesOnEdge') then + allocate(edgesOnEdge_save) + edgesOnEdge_ptr => edgesOnEdge_save + call mpas_pool_get_field(allFields, 'edgesOnEdge', edgesOnEdge) + else if (trim(fieldItr % memberName) == 'cellsOnVertex') then + allocate(cellsOnVertex_save) + cellsOnVertex_ptr => cellsOnVertex_save + call mpas_pool_get_field(allFields, 'cellsOnVertex', cellsOnVertex) + else if (trim(fieldItr % memberName) == 'edgesOnVertex') then + allocate(edgesOnVertex_save) + edgesOnVertex_ptr => edgesOnVertex_save + call mpas_pool_get_field(allFields, 'edgesOnVertex', edgesOnVertex) + end if + end if + + end do + + ! + ! Reindex connectivity from local to global index space + ! + call mpas_pool_get_field(allFields, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_field(allFields, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_field(allFields, 'indexToCellID', indexToCellID) + call mpas_pool_get_field(allFields, 'indexToEdgeID', indexToEdgeID) + call mpas_pool_get_field(allFields, 'indexToVertexID', indexToVertexID) + + do while (associated(indexToCellID)) + + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'nVertices', nVertices) + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'maxEdges', maxEdges) + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'maxEdges2', maxEdges2) + call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'vertexDegree', vertexDegree) + + if (associated(cellsOnCell)) then + nullify(cellsOnCell_ptr % ioinfo) + cellsOnCell_ptr % array => cellsOnCell % array + allocate(cellsOnCell % array(maxEdges, nCells+1)) + + do i = 1, nCellsSolve + do j = 1, nEdgesOnCell % array(i) + cellsOnCell % array(j,i) = indexToCellID % array(cellsOnCell_ptr % array(j,i)) + end do + + cellsOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nCells+1 + end do + + cellsOnCell => cellsOnCell % next + if (associated(cellsOnCell)) then + allocate(cellsOnCell_ptr % next) + cellsOnCell_ptr => cellsOnCell_ptr % next + end if + nullify(cellsOnCell_ptr % next) + end if + + if (associated(edgesOnCell)) then + nullify(edgesOnCell_ptr % ioinfo) + edgesOnCell_ptr % array => edgesOnCell % array + allocate(edgesOnCell % array(maxEdges, nCells+1)) + + do i = 1, nCellsSolve + do j = 1, nEdgesOnCell % array(i) + edgesOnCell % array(j,i) = indexToEdgeID % array(edgesOnCell_ptr % array(j,i)) + end do + + edgesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nEdges+1 + end do + + edgesOnCell => edgesOnCell % next + if (associated(edgesOnCell)) then + allocate(edgesOnCell_ptr % next) + edgesOnCell_ptr => edgesOnCell_ptr % next + end if + nullify(edgesOnCell_ptr % next) + end if + + if (associated(verticesOnCell)) then + nullify(verticesOnCell_ptr % ioinfo) + verticesOnCell_ptr % array => verticesOnCell % array + allocate(verticesOnCell % array(maxEdges, nCells+1)) + + do i = 1, nCellsSolve + do j = 1, nEdgesOnCell % array(i) + verticesOnCell % array(j,i) = indexToVertexID % array(verticesOnCell_ptr % array(j,i)) + end do + + verticesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nVertices+1 + end do + + verticesOnCell => verticesOnCell % next + if (associated(verticesOnCell)) then + allocate(verticesOnCell_ptr % next) + verticesOnCell_ptr => verticesOnCell_ptr % next + end if + nullify(verticesOnCell_ptr % next) + end if + + if (associated(cellsOnEdge)) then + nullify(cellsOnEdge_ptr % ioinfo) + cellsOnEdge_ptr % array => cellsOnEdge % array + allocate(cellsOnEdge % array(2, nEdges+1)) + + do i = 1, nEdgesSolve + cellsOnEdge % array(1,i) = indexToCellID % array(cellsOnEdge_ptr % array(1,i)) + cellsOnEdge % array(2,i) = indexToCellID % array(cellsOnEdge_ptr % array(2,i)) + end do + + cellsOnEdge => cellsOnEdge % next + if (associated(cellsOnEdge)) then + allocate(cellsOnEdge_ptr % next) + cellsOnEdge_ptr => cellsOnEdge_ptr % next + end if + nullify(cellsOnEdge_ptr % next) + end if + + if (associated(verticesOnEdge)) then + nullify(verticesOnEdge_ptr % ioinfo) + verticesOnEdge_ptr % array => verticesOnEdge % array + allocate(verticesOnEdge % array(2, nEdges+1)) + + do i = 1, nEdgesSolve + verticesOnEdge % array(1,i) = indexToVertexID % array(verticesOnEdge_ptr % array(1,i)) + verticesOnEdge % array(2,i) = indexToVertexID % array(verticesOnEdge_ptr % array(2,i)) + end do + + verticesOnEdge => verticesOnEdge % next + if (associated(verticesOnEdge)) then + allocate(verticesOnEdge_ptr % next) + verticesOnEdge_ptr => verticesOnEdge_ptr % next + end if + nullify(verticesOnEdge_ptr % next) + end if + + if (associated(edgesOnEdge)) then + nullify(edgesOnEdge_ptr % ioinfo) + edgesOnEdge_ptr % array => edgesOnEdge % array + allocate(edgesOnEdge % array(maxEdges2, nEdges+1)) + + do i = 1, nEdgesSolve + do j = 1, nEdgesOnEdge % array(i) + edgesOnEdge % array(j,i) = indexToEdgeID % array(edgesOnEdge_ptr % array(j,i)) + end do + + edgesOnEdge % array(nEdgesOnEdge%array(i)+1:maxEdges2,i) = nEdges+1 + end do + + edgesOnEdge => edgesOnEdge % next + if (associated(edgesOnEdge)) then + allocate(edgesOnEdge_ptr % next) + edgesOnEdge_ptr => edgesOnEdge_ptr % next + end if + nullify(edgesOnEdge_ptr % next) + end if + + if (associated(cellsOnVertex)) then + nullify(cellsOnVertex_ptr % ioinfo) + cellsOnVertex_ptr % array => cellsOnVertex % array + allocate(cellsOnVertex % array(vertexDegree, nVertices+1)) + + do i = 1, nVerticesSolve + do j = 1, vertexDegree + cellsOnVertex % array(j,i) = indexToCellID % array(cellsOnVertex_ptr % array(j,i)) + end do + end do + + cellsOnVertex => cellsOnVertex % next + if (associated(cellsOnVertex)) then + allocate(cellsOnVertex_ptr % next) + cellsOnVertex_ptr => cellsOnVertex_ptr % next + end if + nullify(cellsOnVertex_ptr % next) + end if + + if (associated(edgesOnVertex)) then + nullify(edgesOnVertex_ptr % ioinfo) + edgesOnVertex_ptr % array => edgesOnVertex % array + allocate(edgesOnVertex % array(vertexDegree, nVertices+1)) + + do i = 1, nVerticesSolve + do j = 1, vertexDegree + edgesOnVertex % array(j,i) = indexToEdgeID % array(edgesOnVertex_ptr % array(j,i)) + end do + end do + + edgesOnVertex => edgesOnVertex % next + if (associated(edgesOnVertex)) then + allocate(edgesOnVertex_ptr % next) + edgesOnVertex_ptr => edgesOnVertex_ptr % next + end if + nullify(edgesOnVertex_ptr % next) + end if + + nEdgesOnCell => nEdgesOnCell % next + nEdgesOnEdge => nEdgesOnEdge % next + indexToCellID => indexToCellID % next + indexToEdgeID => indexToEdgeID % next + indexToVertexID => indexToVertexID % next + + end do + + end subroutine prewrite_reindex !}}} + + + !----------------------------------------------------------------------- + ! routine postwrite_reindex + ! + !> \brief Reindex connectivity fields from global to local index space. + !> \author Doug Jacobsen, Michael Duda + !> \date 24 September 2014 + !> \details + !> For any connectivity fields contained in the stream to be written, + !> whose fields include those in the streamFields pool, restore the locally + !> indexed fields from module variables *_save. + !> This routine should be called immediately after a write of a stream. + !> + !> NB: Even if the write of a stream fails, it is important to stil call + !> this routine to reset the connectivity fields to contain local indices. + ! + !----------------------------------------------------------------------- + subroutine postwrite_reindex(allFields, streamFields) !{{{ + + implicit none + + type (mpas_pool_type), pointer :: allFields + type (mpas_pool_type), pointer :: streamFields + + type (field1dInteger), pointer :: indexToCellID + + type (field2dInteger), pointer :: cellsOnCell_ptr, edgesOnCell_ptr, verticesOnCell_ptr, & + cellsOnEdge_ptr, verticesOnEdge_ptr, edgesOnEdge_ptr, & + cellsOnVertex_ptr, edgesOnVertex_ptr + + type (field2dInteger), pointer :: cellsOnCell, edgesOnCell, verticesOnCell, & + cellsOnEdge, verticesOnEdge, edgesOnEdge, & + cellsOnVertex, edgesOnVertex + + integer :: i, j + + + nullify(cellsOnCell) + nullify(edgesOnCell) + nullify(verticesOnCell) + nullify(cellsOnEdge) + nullify(verticesOnEdge) + nullify(edgesOnEdge) + nullify(cellsOnVertex) + nullify(edgesOnVertex) + + if (associated(cellsOnCell_save)) then + cellsOnCell_ptr => cellsOnCell_save + call mpas_pool_get_field(allFields, 'cellsOnCell', cellsOnCell) + end if + if (associated(edgesOnCell_save)) then + edgesOnCell_ptr => edgesOnCell_save + call mpas_pool_get_field(allFields, 'edgesOnCell', edgesOnCell) + end if + if (associated(verticesOnCell_save)) then + verticesOnCell_ptr => verticesOnCell_save + call mpas_pool_get_field(allFields, 'verticesOnCell', verticesOnCell) + end if + if (associated(cellsOnEdge_save)) then + cellsOnEdge_ptr => cellsOnEdge_save + call mpas_pool_get_field(allFields, 'cellsOnEdge', cellsOnEdge) + end if + if (associated(verticesOnEdge_save)) then + verticesOnEdge_ptr => verticesOnEdge_save + call mpas_pool_get_field(allFields, 'verticesOnEdge', verticesOnEdge) + end if + if (associated(edgesOnEdge_save)) then + edgesOnEdge_ptr => edgesOnEdge_save + call mpas_pool_get_field(allFields, 'edgesOnEdge', edgesOnEdge) + end if + if (associated(cellsOnVertex_save)) then + cellsOnVertex_ptr => cellsOnVertex_save + call mpas_pool_get_field(allFields, 'cellsOnVertex', cellsOnVertex) + end if + if (associated(edgesOnVertex_save)) then + edgesOnVertex_ptr => edgesOnVertex_save + call mpas_pool_get_field(allFields, 'edgesOnVertex', edgesOnVertex) + end if + + ! + ! Reset indices for connectivity arrays from global to local index space + ! + call mpas_pool_get_field(allFields, 'indexToCellID', indexToCellID) + do while (associated(indexToCellID)) + + if (associated(cellsOnCell)) then + deallocate(cellsOnCell % array) + cellsOnCell % array => cellsOnCell_ptr % array + nullify(cellsOnCell_ptr % array) + cellsOnCell_ptr => cellsOnCell_ptr % next + cellsOnCell => cellsOnCell % next + end if + + if (associated(edgesOnCell)) then + deallocate(edgesOnCell % array) + edgesOnCell % array => edgesOnCell_ptr % array + nullify(edgesOnCell_ptr % array) + edgesOnCell_ptr => edgesOnCell_ptr % next + edgesOnCell => edgesOnCell % next + end if + + if (associated(verticesOnCell)) then + deallocate(verticesOnCell % array) + verticesOnCell % array => verticesOnCell_ptr % array + nullify(verticesOnCell_ptr % array) + verticesOnCell_ptr => verticesOnCell_ptr % next + verticesOnCell => verticesOnCell % next + end if + + if (associated(cellsOnEdge)) then + deallocate(cellsOnEdge % array) + cellsOnEdge % array => cellsOnEdge_ptr % array + nullify(cellsOnEdge_ptr % array) + cellsOnEdge_ptr => cellsOnEdge_ptr % next + cellsOnEdge => cellsOnEdge % next + end if + + if (associated(verticesOnEdge)) then + deallocate(verticesOnEdge % array) + verticesOnEdge % array => verticesOnEdge_ptr % array + nullify(verticesOnEdge_ptr % array) + verticesOnEdge_ptr => verticesOnEdge_ptr % next + verticesOnEdge => verticesOnEdge % next + end if + + if (associated(edgesOnEdge)) then + deallocate(edgesOnEdge % array) + edgesOnEdge % array => edgesOnEdge_ptr % array + nullify(edgesOnEdge_ptr % array) + edgesOnEdge_ptr => edgesOnEdge_ptr % next + edgesOnEdge => edgesOnEdge % next + end if + + if (associated(cellsOnVertex)) then + deallocate(cellsOnVertex % array) + cellsOnVertex % array => cellsOnVertex_ptr % array + nullify(cellsOnVertex_ptr % array) + cellsOnVertex_ptr => cellsOnVertex_ptr % next + cellsOnVertex => cellsOnVertex % next + end if + + if (associated(edgesOnVertex)) then + deallocate(edgesOnVertex % array) + edgesOnVertex % array => edgesOnVertex_ptr % array + nullify(edgesOnVertex_ptr % array) + edgesOnVertex_ptr => edgesOnVertex_ptr % next + edgesOnVertex => edgesOnVertex % next + end if + + indexToCellID => indexToCellID % next + end do + + if (associated(cellsOnCell_save)) call mpas_deallocate_field(cellsOnCell_save) + if (associated(edgesOnCell_save)) call mpas_deallocate_field(edgesOnCell_save) + if (associated(verticesOnCell_save)) call mpas_deallocate_field(verticesOnCell_save) + if (associated(cellsOnEdge_save)) call mpas_deallocate_field(cellsOnEdge_save) + if (associated(verticesOnEdge_save)) call mpas_deallocate_field(verticesOnEdge_save) + if (associated(edgesOnEdge_save)) call mpas_deallocate_field(edgesOnEdge_save) + if (associated(cellsOnVertex_save)) call mpas_deallocate_field(cellsOnVertex_save) + if (associated(edgesOnVertex_save)) call mpas_deallocate_field(edgesOnVertex_save) + + nullify(cellsOnCell_save) + nullify(edgesOnCell_save) + nullify(verticesOnCell_save) + nullify(cellsOnEdge_save) + nullify(verticesOnEdge_save) + nullify(edgesOnEdge_save) + nullify(cellsOnVertex_save) + nullify(edgesOnVertex_save) + + end subroutine postwrite_reindex !}}} + + + !----------------------------------------------------------------------- + ! routine postread_reindex + ! + !> \brief Reindex connectivity fields from global to local index space. + !> \author Doug Jacobsen, Michael Duda + !> \date 24 September 2014 + !> \details + !> For any connectivity fields contained in the stream that was read, + !> whose fields include those in the streamFields pool, convert the + !> globally indexed connectivity fields in the stream to local index space. + !> This routine should be called immediately after a read of a stream. + ! + !----------------------------------------------------------------------- + subroutine postread_reindex(allFields, streamFields) !{{{ + + implicit none + + type (mpas_pool_type), pointer :: allFields + type (mpas_pool_type), pointer :: streamFields + + type (mpas_pool_iterator_type) :: fieldItr + type (mpas_pool_field_info_type) :: fieldInfo + + type (field1DInteger), pointer :: indexToCellID, indexToVertexID, indexToEdgeID, nEdgesOnCell, cursor + type (field2DInteger), pointer :: int2DField +!TODO: Use a short string kind here? + character(len=32) :: outDimName, indexSpaceName + integer, dimension(:,:), pointer :: sortedID + integer :: innerDim + integer, pointer :: outerDim, indexSpaceDim + logical :: skip_field + integer :: i, j, k + + + call mpas_pool_get_field(allFields, 'indexToCellID', indexToCellID) + call mpas_pool_get_field(allFields, 'indexToEdgeID', indexToEdgeID) + call mpas_pool_get_field(allFields, 'indexToVertexID', indexToVertexID) + + call mpas_pool_begin_iteration(streamFields) + + do while ( mpas_pool_get_next_member(streamFields, fieldItr) ) + + ! Note: in a stream's field_pool, the names of fields are stored as configs + if ( fieldItr % memberType == MPAS_POOL_CONFIG ) then + + call mpas_pool_get_field_info(allFields, fieldItr % memberName, fieldInfo) + + skip_field = .false. + if (trim(fieldItr % memberName) == 'cellsOnCell') then + + STREAM_DEBUG_WRITE('-- Reindexing cellsOnCell') + + ! Get pointer to the field to be reindexed + call mpas_pool_get_field(allFields, 'cellsOnCell', int2DField) + + ! Set the name of the outer dimension + outDimName = 'nCells' + + ! Set the name of the dimension of the space within which we are indexing dimension + indexSpaceName = 'nCells' + + ! Get pointer to appropriate global index field + cursor => indexToCellID + + else if (trim(fieldItr % memberName) == 'edgesOnCell') then + + STREAM_DEBUG_WRITE('-- Reindexing edgesOnCell') + + ! Get pointer to the field to be reindexed + call mpas_pool_get_field(allFields, 'edgesOnCell', int2DField) + + ! Set the name of the outer dimension + outDimName = 'nCells' + + ! Set the name of the dimension of the space within which we are indexing dimension + indexSpaceName = 'nEdges' + + ! Get pointer to appropriate global index field + cursor => indexToEdgeID + + else if (trim(fieldItr % memberName) == 'verticesOnCell') then + + STREAM_DEBUG_WRITE('-- Reindexing verticesOnCell') + + ! Get pointer to the field to be reindexed + call mpas_pool_get_field(allFields, 'verticesOnCell', int2DField) + + ! Set the name of the outer dimension + outDimName = 'nCells' + + ! Set the name of the dimension of the space within which we are indexing dimension + indexSpaceName = 'nVertices' + + ! Get pointer to appropriate global index field + cursor => indexToVertexID + + else if (trim(fieldItr % memberName) == 'cellsOnEdge') then + + STREAM_DEBUG_WRITE('-- Reindexing cellsOnEdge') + + ! Get pointer to the field to be reindexed + call mpas_pool_get_field(allFields, 'cellsOnEdge', int2DField) + + ! Set the name of the outer dimension + outDimName = 'nEdges' + + ! Set the name of the dimension of the space within which we are indexing dimension + indexSpaceName = 'nCells' + + ! Get pointer to appropriate global index field + cursor => indexToCellID + + else if (trim(fieldItr % memberName) == 'verticesOnEdge') then + + STREAM_DEBUG_WRITE('-- Reindexing verticesOnEdge') + + ! Get pointer to the field to be reindexed + call mpas_pool_get_field(allFields, 'verticesOnEdge', int2DField) + + ! Set the name of the outer dimension + outDimName = 'nEdges' + + ! Set the name of the dimension of the space within which we are indexing dimension + indexSpaceName = 'nVertices' + + ! Get pointer to appropriate global index field + cursor => indexToVertexID + + else if (trim(fieldItr % memberName) == 'edgesOnEdge') then + + STREAM_DEBUG_WRITE('-- Reindexing edgesOnEdge') + + ! Get pointer to the field to be reindexed + call mpas_pool_get_field(allFields, 'edgesOnEdge', int2DField) + + ! Set the name of the outer dimension + outDimName = 'nEdges' + + ! Set the name of the dimension of the space within which we are indexing dimension + indexSpaceName = 'nEdges' + + ! Get pointer to appropriate global index field + cursor => indexToEdgeID + + else if (trim(fieldItr % memberName) == 'cellsOnVertex') then + + STREAM_DEBUG_WRITE('-- Reindexing cellsOnVertex') + + ! Get pointer to the field to be reindexed + call mpas_pool_get_field(allFields, 'cellsOnVertex', int2DField) + + ! Set the name of the outer dimension + outDimName = 'nVertices' + + ! Set the name of the dimension of the space within which we are indexing dimension + indexSpaceName = 'nCells' + + ! Get pointer to appropriate global index field + cursor => indexToCellID + + else if (trim(fieldItr % memberName) == 'edgesOnVertex') then + + STREAM_DEBUG_WRITE('-- Reindexing edgesOnVertex') + + ! Get pointer to the field to be reindexed + call mpas_pool_get_field(allFields, 'edgesOnVertex', int2DField) + + ! Set the name of the outer dimension + outDimName = 'nVertices' + + ! Set the name of the dimension of the space within which we are indexing dimension + indexSpaceName = 'nEdges' + + ! Get pointer to appropriate global index field + cursor => indexToEdgeID + + else + skip_field = .true. + end if + + if (.not. skip_field) then + + ! Get inner dimension of field to be reindexed (assumed to be block invariant) + innerDim = int2DField % dimSizes(1) + + ! Reindex all blocks for the field + do while (associated(int2DField)) + + ! Get outer dimension of field for this block + call mpas_pool_get_dimension(cursor % block % dimensions, trim(outDimName), outerDim) + call mpas_pool_get_dimension(cursor % block % dimensions, trim(indexSpaceName), indexSpaceDim) + + ! Set-up reindexing map + allocate(sortedID(2,indexSpaceDim)) + do i = 1, indexSpaceDim + sortedID(1,i) = cursor % array(i) + sortedID(2,i) = i + end do + call mpas_quicksort(indexSpaceDim, sortedID) + + ! Reindex the field + do i = 1, outerDim + do j = 1, innerDim + k = mpas_binary_search(sortedID, 2, 1, indexSpaceDim, int2DField % array(j,i)) + if (k <= indexSpaceDim) then + int2DField % array(j,i) = sortedID(2,k) + else + int2DField % array(j,i) = indexSpaceDim + 1 + end if + end do + end do + + deallocate(sortedID) + int2DField => int2DField % next + cursor => cursor % next + + end do + + end if + + end if + + end do + + end subroutine postread_reindex !}}} + + +end module mpas_stream_manager + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! C interface routines for building streams at run-time +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +subroutine stream_mgr_create_stream_c(manager_c, streamID_c, direction_c, filename_c, filename_intv_c, ref_time_c, rec_intv_c, & + immutable_c, precision_c, clobber_c, ierr_c) bind(c) !{{{ + + use mpas_c_interfacing, only : mpas_c_to_f_string + use iso_c_binding, only : c_char, c_int, c_ptr, c_f_pointer + use mpas_stream_manager, only : MPAS_streamManager_type, MPAS_STREAM_MGR_NOERR, MPAS_STREAM_PROPERTY_FILENAME, & + MPAS_STREAM_PROPERTY_FILENAME_INTV, MPAS_STREAM_PROPERTY_REF_TIME, & + MPAS_STREAM_PROPERTY_RECORD_INTV, MPAS_STREAM_PROPERTY_PRECISION, & + MPAS_STREAM_PROPERTY_CLOBBER, MPAS_STREAM_CLOBBER_NEVER, MPAS_STREAM_CLOBBER_APPEND, & + MPAS_STREAM_CLOBBER_TRUNCATE, MPAS_STREAM_CLOBBER_OVERWRITE, MPAS_stream_mgr_create_stream, & + MPAS_stream_mgr_set_property + + use mpas_kind_types, only : StrKIND + use mpas_io, only : MPAS_IO_SINGLE_PRECISION, MPAS_IO_DOUBLE_PRECISION, MPAS_IO_NATIVE_PRECISION + use mpas_io_units, only : stderrUnit + + implicit none + + type (c_ptr) :: manager_c + character(kind=c_char) :: streamID_c(*) + integer(kind=c_int) :: direction_c + character(kind=c_char) :: filename_c(*) + character(kind=c_char) :: filename_intv_c(*) + character(kind=c_char) :: ref_time_c(*) + character(kind=c_char) :: rec_intv_c(*) + integer(kind=c_int) :: immutable_c + integer(kind=c_int) :: precision_c + integer(kind=c_int) :: clobber_c + integer(kind=c_int) :: ierr_c + + type (MPAS_streamManager_type), pointer :: manager + character(len=StrKIND) :: streamID, filename, filename_interval, reference_time, record_interval + integer :: direction, immutable, prec, ierr + integer :: clobber_mode + + call c_f_pointer(manager_c, manager) + call mpas_c_to_f_string(streamID_c, streamID) + direction = direction_c + call mpas_c_to_f_string(filename_c, filename) + call mpas_c_to_f_string(filename_intv_c, filename_interval) + call mpas_c_to_f_string(ref_time_c, reference_time) + call mpas_c_to_f_string(rec_intv_c, record_interval) + immutable = immutable_c + + if (precision_c == 4) then + prec = MPAS_IO_SINGLE_PRECISION + else if (precision_c == 8) then + prec = MPAS_IO_DOUBLE_PRECISION + else + prec = MPAS_IO_NATIVE_PRECISION + end if + + if (clobber_c == 0) then + clobber_mode = MPAS_STREAM_CLOBBER_NEVER + else if (clobber_c == 1) then + clobber_mode = MPAS_STREAM_CLOBBER_APPEND + else if (clobber_c == 2) then + clobber_mode = MPAS_STREAM_CLOBBER_TRUNCATE + else if (clobber_c == 3) then + clobber_mode = MPAS_STREAM_CLOBBER_OVERWRITE + else + clobber_mode = MPAS_STREAM_CLOBBER_NEVER + end if + + STREAM_DEBUG_WRITE('Creating stream from c...') + + ! + ! For immutable streams, the stream should have already been defined at this point, and + ! all we need to do is update the stream's filename template; + ! otherwise, we need to create a new stream + ! + ierr = 0 + if (immutable == 1) then + call MPAS_stream_mgr_set_property(manager, streamID, MPAS_STREAM_PROPERTY_FILENAME, filename, ierr=ierr) + + ! If we can't set a property on this immutable stream, most likely the stream wasn't defined in the core's Registry.xml file + if (ierr /= MPAS_STREAM_MGR_NOERR) then + write(stderrUnit,*) '********************************************************************************' + write(stderrUnit,*) ' Error: Stream '''//trim(streamID)//''' was not defined in the Registry.xml file as ' + write(stderrUnit,*) ' an immutable stream. Immutable streams may only be defined in the Registry.xml' + write(stderrUnit,*) ' file for a core.' + write(stderrUnit,*) '********************************************************************************' + ierr_c = 1 + return + end if + call MPAS_stream_mgr_set_property(manager, streamID, MPAS_STREAM_PROPERTY_PRECISION, prec, ierr=ierr) + call MPAS_stream_mgr_set_property(manager, streamID, MPAS_STREAM_PROPERTY_CLOBBER, clobber_mode, ierr=ierr) + else + call MPAS_stream_mgr_create_stream(manager, streamID, direction, filename, realPrecision=prec, & + clobberMode=clobber_mode, ierr=ierr) + end if + + if (reference_time /= 'initial_time') then + call MPAS_stream_mgr_set_property(manager, streamID, MPAS_STREAM_PROPERTY_REF_TIME, reference_time, ierr=ierr) + end if + + if (record_interval /= 'none') then + call MPAS_stream_mgr_set_property(manager, streamID, MPAS_STREAM_PROPERTY_RECORD_INTV, record_interval, ierr=ierr) + end if + + if (trim(filename_interval) /= 'none') then + call MPAS_stream_mgr_set_property(manager, streamID, MPAS_STREAM_PROPERTY_FILENAME_INTV, filename_interval, ierr=ierr) + end if + + if (ierr == MPAS_STREAM_MGR_NOERR) then + ierr_c = 0 + else + ierr_c = 1 + end if + +end subroutine stream_mgr_create_stream_c !}}} + + +subroutine stream_mgr_add_pool_c(manager_c, streamID_c, poolName_c, ierr_c) bind(c)!{{{ + + use mpas_c_interfacing, only : mpas_c_to_f_string + use iso_c_binding, only : c_char, c_int, c_ptr, c_f_pointer + use mpas_stream_manager, only : MPAS_streamManager_type, MPAS_STREAM_MGR_NOERR, MPAS_stream_mgr_add_pool + use mpas_kind_types, only : StrKIND + + implicit none + + type (c_ptr) :: manager_c + character(kind=c_char) :: streamID_c(*) + character(kind=c_char) :: poolName_c(*) + integer(kind=c_int) :: ierr_c + + type (MPAS_streamManager_type), pointer :: manager + character(len=StrKIND) :: streamID, poolName + integer :: ierr + + + call c_f_pointer(manager_c, manager) + call mpas_c_to_f_string(streamID_c, streamID) + call mpas_c_to_f_string(poolName_c, poolName) + + call MPAS_stream_mgr_add_pool(manager, streamID, poolName, ierr) + + if (ierr == MPAS_STREAM_MGR_NOERR) then + ierr_c = 0 + else + ierr_c = 1 + end if + +end subroutine stream_mgr_add_pool_c!}}} + + +subroutine stream_mgr_add_field_c(manager_c, streamID_c, fieldName_c, ierr_c) bind(c) !{{{ + + use mpas_c_interfacing, only : mpas_c_to_f_string + use iso_c_binding, only : c_char, c_int, c_ptr, c_f_pointer + use mpas_stream_manager, only : MPAS_streamManager_type, MPAS_STREAM_MGR_NOERR, MPAS_stream_mgr_add_field + use mpas_kind_types, only : StrKIND + + implicit none + + type (c_ptr) :: manager_c + character(kind=c_char) :: streamID_c(*) + character(kind=c_char) :: fieldName_c(*) + integer(kind=c_int) :: ierr_c + + type (MPAS_streamManager_type), pointer :: manager + character(len=StrKIND) :: streamID, fieldName + integer :: ierr + + + call c_f_pointer(manager_c, manager) + call mpas_c_to_f_string(streamID_c, streamID) + call mpas_c_to_f_string(fieldName_c, fieldName) + + call MPAS_stream_mgr_add_field(manager, streamID, fieldName, ierr) + + if (ierr == MPAS_STREAM_MGR_NOERR) then + ierr_c = 0 + else + ierr_c = 1 + end if + +end subroutine stream_mgr_add_field_c !}}} + + +subroutine stream_mgr_add_stream_fields_c(manager_c, streamID_c, refStreamID_c, ierr_c) bind(c) !{{{ + + use mpas_c_interfacing, only : mpas_c_to_f_string + use iso_c_binding, only : c_char, c_int, c_ptr, c_f_pointer + use mpas_stream_manager, only : MPAS_streamManager_type, MPAS_STREAM_MGR_NOERR, MPAS_stream_mgr_add_stream_fields + use mpas_kind_types, only : StrKIND + + implicit none + + type (c_ptr) :: manager_c + character(kind=c_char) :: streamID_c(*) + character(kind=c_char) :: refStreamID_c(*) + integer(kind=c_int) :: ierr_c + + type (MPAS_streamManager_type), pointer :: manager + character(len=StrKIND) :: streamID, refStreamID + integer :: ierr + + + call c_f_pointer(manager_c, manager) + call mpas_c_to_f_string(streamID_c, streamID) + call mpas_c_to_f_string(refStreamID_c, refStreamID) + + call MPAS_stream_mgr_add_stream_fields(manager, streamID, refStreamID, ierr) + + if (ierr == MPAS_STREAM_MGR_NOERR) then + ierr_c = 0 + else + ierr_c = 1 + end if + +end subroutine stream_mgr_add_stream_fields_c !}}} + + +subroutine stream_mgr_add_alarm_c(manager_c, streamID_c, direction_c, alarmTime_c, alarmInterval_c, ierr_c) bind(c) !{{{ + + use mpas_c_interfacing, only : mpas_c_to_f_string + use iso_c_binding, only : c_char, c_int, c_ptr, c_f_pointer + use mpas_stream_manager, only : MPAS_streamManager_type, MPAS_STREAM_MGR_NOERR, MPAS_STREAM_INPUT, MPAS_STREAM_OUTPUT, & + MPAS_stream_mgr_get_clock, MPAS_stream_mgr_add_alarm + use mpas_kind_types, only : StrKIND + use mpas_timekeeping, only : MPAS_Clock_type, MPAS_START_TIME, MPAS_Time_type, MPAS_TimeInterval_type, mpas_add_clock_alarm, & + mpas_set_time, mpas_set_timeInterval, mpas_get_clock_time + + implicit none + + type (c_ptr) :: manager_c + character(kind=c_char) :: streamID_c(*) + character(kind=c_char) :: direction_c(*) + character(kind=c_char) :: alarmTime_c(*) + character(kind=c_char) :: alarmInterval_c(*) + integer(kind=c_int) :: ierr_c + + type (MPAS_streamManager_type), pointer :: manager + type (MPAS_Clock_type), pointer :: clock + character(len=StrKIND) :: streamID, direction, alarmID, alarmTime, alarmInterval + type (MPAS_Time_type) :: alarmTime_local + type (MPAS_TimeInterval_type) :: alarmInterval_local + integer :: idirection + integer :: ierr + + + ierr = 0 + + call c_f_pointer(manager_c, manager) + call mpas_c_to_f_string(streamID_c, streamID) + call mpas_c_to_f_string(direction_c, direction) + call mpas_c_to_f_string(alarmTime_c, alarmTime) + call mpas_c_to_f_string(alarmInterval_c, alarmInterval) + write(alarmID, '(a)') trim(streamID)//'_'//trim(direction) + + ! Nothing to do for this stream + if (trim(alarmInterval) == 'none') then + return + end if + + if (trim(direction) == 'input') then + idirection = MPAS_STREAM_INPUT + else if (trim(direction) == 'output') then + idirection = MPAS_STREAM_OUTPUT + end if + + call MPAS_stream_mgr_get_clock(manager, clock) + + if (trim(alarmTime) == 'start') then + alarmTime_local = mpas_get_clock_time(clock, MPAS_START_TIME, ierr=ierr) + else + call mpas_set_time(alarmTime_local, dateTimeString=alarmTime) + end if + + if (trim(alarmInterval) == 'initial_only') then + call mpas_add_clock_alarm(clock, alarmID, alarmTime_local, ierr=ierr) + else + call mpas_set_timeInterval(alarmInterval_local, timeString=alarmInterval) + call mpas_add_clock_alarm(clock, alarmID, alarmTime_local, alarmTimeInterval=alarmInterval_local, ierr=ierr) + end if + + call MPAS_stream_mgr_add_alarm(manager, streamID, alarmID, idirection, ierr=ierr) + + if (ierr == MPAS_STREAM_MGR_NOERR) then + ierr_c = 0 + else + ierr_c = 1 + end if + +end subroutine stream_mgr_add_alarm_c !}}} + + +subroutine stream_mgr_add_pkg_c(manager_c, streamID_c, package_c, ierr_c) bind(c) !{{{ + + use mpas_c_interfacing, only : mpas_c_to_f_string + use iso_c_binding, only : c_char, c_int, c_ptr, c_f_pointer + use mpas_stream_manager, only : MPAS_streamManager_type, MPAS_STREAM_MGR_NOERR, MPAS_stream_mgr_add_pkg + use mpas_kind_types, only : StrKIND + + implicit none + + type (c_ptr) :: manager_c + character(kind=c_char) :: streamID_c(*) + character(kind=c_char) :: package_c(*) + integer(kind=c_int) :: ierr_c + + type (MPAS_streamManager_type), pointer :: manager + character(len=StrKIND) :: streamID, package + integer :: idirection + integer :: ierr + + + ierr = 0 + + call c_f_pointer(manager_c, manager) + call mpas_c_to_f_string(streamID_c, streamID) + call mpas_c_to_f_string(package_c, package) + write(package, '(a)') trim(package)//'Active' + + call MPAS_stream_mgr_add_pkg(manager, streamID, package, ierr=ierr) + + if (ierr == MPAS_STREAM_MGR_NOERR) then + ierr_c = 0 + else + ierr_c = 1 + end if + +end subroutine stream_mgr_add_pkg_c !}}} diff --git a/src/framework/mpas_timekeeping.F b/src/framework/mpas_timekeeping.F index ee274bfb28..77d8e935d5 100644 --- a/src/framework/mpas_timekeeping.F +++ b/src/framework/mpas_timekeeping.F @@ -9,6 +9,7 @@ module mpas_timekeeping use mpas_kind_types use mpas_io_units + use ESMF use ESMF_BaseMod use ESMF_Stubs use ESMF_CalendarMod @@ -30,11 +31,11 @@ module mpas_timekeeping MPAS_360DAY = 2 integer :: TheCalendar + integer :: yearWidth integer, dimension(12), parameter :: daysInMonth = (/31,28,31,30,31,30,31,31,30,31,30,31/) integer, dimension(12), parameter :: daysInMonthLeap = (/31,29,31,30,31,30,31,31,30,31,30,31/) - type MPAS_Time_type type (ESMF_Time) :: t end type @@ -44,7 +45,7 @@ module mpas_timekeeping end type type MPAS_Alarm_type - integer :: alarmID + character (len=ShortStrKIND) :: alarmID logical :: isRecurring logical :: isSet type (MPAS_Time_type) :: ringTime @@ -127,13 +128,13 @@ subroutine mpas_timekeeping_init(calendar) #ifndef MPAS_CESM if (trim(calendar) == 'gregorian') then TheCalendar = MPAS_GREGORIAN - call ESMF_Initialize(defaultCalendar=ESMF_CAL_GREGORIAN) + call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_GREGORIAN) else if (trim(calendar) == 'gregorian_noleap') then TheCalendar = MPAS_GREGORIAN_NOLEAP - call ESMF_Initialize(defaultCalendar=ESMF_CAL_NOLEAP) - else if (trim(calendar) == '360day') then - TheCalendar = MPAS_360DAY - call ESMF_Initialize(defaultCalendar=ESMF_CAL_360DAY) + call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_NOLEAP) +! else if (trim(calendar) == '360day') then +! TheCalendar = MPAS_360DAY +! call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_360DAY) else write(stderrUnit,*) 'ERROR: mpas_timekeeping_init: Invalid calendar type' end if @@ -147,6 +148,8 @@ subroutine mpas_timekeeping_init(calendar) end if #endif + yearWidth = 4 + end subroutine mpas_timekeeping_init @@ -160,6 +163,33 @@ subroutine mpas_timekeeping_finalize() end subroutine mpas_timekeeping_finalize + !----------------------------------------------------------------------- + ! routine mpas_timekeeping_set_year_width + ! + !> \brief This routine sets the width of the year portion of timestamps. + !> \author Michael Duda, Doug Jacobsen + !> \date 07/23/2014 + !> \details This routine sets the width of the year portion of timestamps. + !> It can be used to make the year portion of a time stamp or an expanded + !> string more than 4 digits, to support years larger than 9999. + !> + !----------------------------------------------------------------------- + subroutine mpas_timekeeping_set_year_width(yearWidthIn)!{{{ + integer, intent(in) :: yearWidthIn + + yearWidth = yearWidthIn + + if (yearWidthIn <= 0) then + write(stderrUnit,*) 'ERROR: mpas_set_year_width: yearWidth cannot be less than or equal to zero.' + ierr = 1 + return + end if + + yearWidth = yearWidthIn + + call ESMF_setYearWidth(yearWidthIn) + + end subroutine mpas_timekeeping_set_year_width!}}} subroutine mpas_create_clock(clock, startTime, timeStep, stopTime, runDuration, ierr) @@ -439,7 +469,7 @@ subroutine mpas_add_clock_alarm(clock, alarmID, alarmTime, alarmTimeInterval, ie implicit none type (MPAS_Clock_type), intent(inout) :: clock - integer, intent(in) :: alarmID + character (len=*), intent(in) :: alarmID type (MPAS_Time_type), intent(in) :: alarmTime type (MPAS_TimeInterval_type), intent(in), optional :: alarmTimeInterval integer, intent(out), optional :: ierr @@ -454,15 +484,15 @@ subroutine mpas_add_clock_alarm(clock, alarmID, alarmTime, alarmTimeInterval, ie else alarmPtr => clock % alarmListHead do while (associated(alarmPtr % next)) - if (alarmPtr % alarmID == alarmID) then - write(stderrUnit,*) 'OOPS -- we have a duplicate alarmID', alarmID + if (trim(alarmPtr % alarmID) == trim(alarmID)) then + write(stderrUnit,*) 'OOPS -- we have a duplicate alarmID', trim(alarmID) if (present(ierr)) ierr = 1 return end if alarmPtr => alarmPtr % next end do - if (alarmPtr % alarmID == alarmID) then - write(stderrUnit,*) 'OOPS -- we have a duplicate alarmID', alarmID + if (trim(alarmPtr % alarmID) == trim(alarmID)) then + write(stderrUnit,*) 'OOPS -- we have a duplicate alarmID', trim(alarmID) if (present(ierr)) ierr = 1 return end if @@ -471,7 +501,7 @@ subroutine mpas_add_clock_alarm(clock, alarmID, alarmTime, alarmTimeInterval, ie nullify(alarmPtr % next) end if - alarmPtr % alarmID = alarmID + alarmPtr % alarmID = trim(alarmID) clock % nAlarms = clock % nAlarms + 1 @@ -503,7 +533,7 @@ subroutine mpas_remove_clock_alarm(clock, alarmID, ierr) implicit none type (MPAS_Clock_type), intent(inout) :: clock - integer, intent(in) :: alarmID + character (len=*), intent(in) :: alarmID integer, intent(out), optional :: ierr type (MPAS_Alarm_type), pointer :: alarmPtr @@ -512,27 +542,105 @@ subroutine mpas_remove_clock_alarm(clock, alarmID, ierr) if (present(ierr)) ierr = 0 alarmPtr => clock % alarmListHead - alarmParentPtr = alarmPtr + alarmParentPtr => alarmPtr do while (associated(alarmPtr)) - if (alarmPtr % alarmID == alarmID) then - alarmParentPtr % next => alarmPtr % next + if (trim(alarmPtr % alarmID) == trim(alarmID)) then + if (trim(alarmPtr % alarmID) == trim(clock % alarmListHead % alarmID)) then + clock % alarmListHead => alarmPtr % next + else + alarmParentPtr % next => alarmPtr % next + end if deallocate(alarmPtr) exit end if - alarmParentPtr = alarmPtr + alarmParentPtr => alarmPtr alarmPtr => alarmPtr % next end do end subroutine mpas_remove_clock_alarm + !----------------------------------------------------------------------- + ! routine mpas_is_alarm_defined + ! + !> \brief Check whether an alarm has been defined on a clock + !> \author Michael Duda + !> \date 26 August 2014 + !> \details + !> For a specified clock and alarm ID, checks whether that alarm ID has + !> been defined on the clock and returns the result. + ! + !----------------------------------------------------------------------- + logical function mpas_is_alarm_defined(clock, alarmID, ierr) + + implicit none + + type (MPAS_Clock_type), intent(in) :: clock + character (len=*), intent(in) :: alarmID + integer, intent(out) :: ierr + + type (MPAS_Alarm_type), pointer :: alarmPtr + + ierr = 0 + mpas_is_alarm_defined = .false. + + alarmPtr => clock % alarmListHead + do while (associated(alarmPtr)) + if (trim(alarmPtr % alarmID) == trim(alarmID)) then + mpas_is_alarm_defined = .true. + return + end if + alarmPtr => alarmPtr % next + end do + + end function mpas_is_alarm_defined + + + !----------------------------------------------------------------------- + ! routine mpas_alarm_interval + ! + !> \brief Retrieve the interval for an alarm + !> \author Michael Duda + !> \date 4 September 2014 + !> \details + !> For a specified clock and alarm ID, returns the time interval + !> associated with the alarm. + ! + !----------------------------------------------------------------------- + type (MPAS_TimeInterval_type) function mpas_alarm_interval(clock, alarmID, ierr) + + implicit none + + type (MPAS_Clock_type), intent(in) :: clock + character (len=*), intent(in) :: alarmID + integer, intent(out) :: ierr + + type (MPAS_Alarm_type), pointer :: alarmPtr + + ierr = 1 + call mpas_set_timeInterval(mpas_alarm_interval, S=0) + + alarmPtr => clock % alarmListHead + do while (associated(alarmPtr)) + if (trim(alarmPtr % alarmID) == trim(alarmID)) then + if (alarmPtr % isSet .and. alarmPtr % isRecurring) then + ierr = 0 + mpas_alarm_interval = alarmPtr % ringTimeInterval + end if + return + end if + alarmPtr => alarmPtr % next + end do + + end function mpas_alarm_interval + subroutine mpas_print_alarm(clock, alarmID, ierr) implicit none type (MPAS_Clock_type), intent(in) :: clock - integer, intent(in) :: alarmID + character (len=*), intent(in) :: alarmID integer, intent(out) :: ierr type (MPAS_Alarm_type), pointer :: alarmPtr @@ -543,8 +651,8 @@ subroutine mpas_print_alarm(clock, alarmID, ierr) alarmPtr => clock % alarmListHead do while (associated(alarmPtr)) - if (alarmPtr % alarmID == alarmID) then - write(stderrUnit,*) 'ALARM ', alarmID + if (trim(alarmPtr % alarmID) == trim(alarmID)) then + write(stderrUnit,*) 'ALARM ', trim(alarmID) write(stderrUnit,*) 'isRecurring', alarmPtr % isRecurring @@ -573,7 +681,7 @@ logical function mpas_is_alarm_ringing(clock, alarmID, interval, ierr) implicit none type (MPAS_Clock_type), intent(in) :: clock - integer, intent(in) :: alarmID + character (len=*), intent(in) :: alarmID type (MPAS_TimeInterval_type), intent(in), optional :: interval integer, intent(out), optional :: ierr @@ -585,7 +693,7 @@ logical function mpas_is_alarm_ringing(clock, alarmID, interval, ierr) alarmPtr => clock % alarmListHead do while (associated(alarmPtr)) - if (alarmPtr % alarmID == alarmID) then + if (trim(alarmPtr % alarmID) == trim(alarmID)) then if (alarmPtr % isSet) then if (mpas_in_ringing_envelope(clock, alarmPtr, interval, ierr)) then mpas_is_alarm_ringing = .true. @@ -606,7 +714,7 @@ subroutine mpas_get_clock_ringing_alarms(clock, nAlarms, alarmList, interval, ie type (MPAS_Clock_type), intent(in) :: clock integer, intent(out) :: nAlarms - integer, dimension(MPAS_MAX_ALARMS), intent(out) :: alarmList + character (len=ShortStrKIND), dimension(MPAS_MAX_ALARMS), intent(out) :: alarmList type (MPAS_TimeInterval_type), intent(in), optional :: interval integer, intent(out), optional :: ierr @@ -621,7 +729,7 @@ subroutine mpas_get_clock_ringing_alarms(clock, nAlarms, alarmList, interval, ie if (alarmPtr % isSet) then if (mpas_in_ringing_envelope(clock, alarmPtr, interval, ierr)) then nAlarms = nAlarms + 1 - alarmList(nAlarms) = alarmPtr % alarmID + alarmList(nAlarms) = trim(alarmPtr % alarmID) end if end if alarmPtr => alarmPtr % next @@ -684,19 +792,22 @@ subroutine mpas_reset_clock_alarm(clock, alarmID, interval, ierr) implicit none type (MPAS_Clock_type), intent(inout) :: clock - integer, intent(in) :: alarmID + character (len=*), intent(in) :: alarmID type (MPAS_TimeInterval_type), intent(in), optional :: interval integer, intent(out), optional :: ierr type (MPAS_Time_type) :: alarmNow type (MPAS_Alarm_type), pointer :: alarmPtr + type (MPAS_TimeInterval_type) :: nowInterval, nowRemainder + integer :: nDivs + if (present(ierr)) ierr = 0 alarmPtr => clock % alarmListHead do while (associated(alarmPtr)) - if (alarmPtr % alarmID == alarmID) then + if (trim(alarmPtr % alarmID) == trim(alarmID)) then if (mpas_in_ringing_envelope(clock, alarmPtr, interval, ierr)) then @@ -710,19 +821,17 @@ subroutine mpas_reset_clock_alarm(clock, alarmID, interval, ierr) alarmNow = alarmNow + interval end if - do while(alarmPtr % prevRingTime <= alarmNow) - alarmPtr % prevRingTime = alarmPtr % prevRingTime + alarmPtr % ringTimeInterval - end do - alarmPtr % prevRingTime = alarmPtr % prevRingTime - alarmPtr % ringTimeInterval + nowInterval = alarmNow - alarmPtr % prevRingTime + call mpas_interval_division(alarmNow, nowInterval, alarmPtr % ringTimeInterval, nDivs, nowRemainder) + alarmPtr % prevRingTime = alarmNow - nowRemainder else if (present(interval)) then alarmNow = alarmNow - interval end if - do while(alarmPtr % prevRingTime >= alarmNow) - alarmPtr % prevRingTime = alarmPtr % prevRingTime - alarmPtr % ringTimeInterval - end do - alarmPtr % prevRingTime = alarmPtr % prevRingTime + alarmPtr % ringTimeInterval + nowInterval = alarmPtr % prevRingTime - alarmNow + call mpas_interval_division(alarmNow, nowInterval, alarmPtr % ringTimeInterval, nDivs, nowRemainder) + alarmPtr % prevRingTime = alarmNow + nowRemainder end if end if end if @@ -988,15 +1097,18 @@ subroutine mpas_get_time(curr_time, YYYY, MM, DD, DoY, H, M, S, S_n, S_d, dateTi end subroutine mpas_get_time - subroutine mpas_set_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt, ierr) + subroutine mpas_set_timeInterval(interval, YY, MM, DD, H, M, S, S_n, S_d, S_i8, timeString, dt, ierr) implicit none type (MPAS_TimeInterval_type), intent(out) :: interval + integer, intent(in), optional :: YY + integer, intent(in), optional :: MM integer, intent(in), optional :: DD integer, intent(in), optional :: H integer, intent(in), optional :: M integer, intent(in), optional :: S + integer (kind=I8KIND), intent(in), optional :: S_i8 integer, intent(in), optional :: S_n integer, intent(in), optional :: S_d character (len=*), intent(in), optional :: timeString @@ -1008,9 +1120,13 @@ subroutine mpas_set_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt integer :: numerator, denominator, denominatorPower type (MPAS_TimeInterval_type) :: zeroInterval - integer :: day, hour, min, sec + integer :: year, month, day, hour, min + integer (kind=I8KIND) :: sec character (len=StrKIND) :: timeString_ + character (len=StrKIND) :: dateSubString character (len=StrKIND) :: daySubString + character (len=StrKIND) :: monthSubString + character (len=StrKIND) :: yearSubString character (len=StrKIND) :: timeSubString character (len=StrKIND) :: secDecSubString character(len=StrKIND), pointer, dimension(:) :: subStrings @@ -1115,14 +1231,38 @@ subroutine mpas_set_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt call mpas_split_string(timeString_, "_", subStrings) - if(size(subStrings) == 2) then ! contains a day and time - daySubString = subStrings(1) + if(size(subStrings) == 2) then ! contains a date and time + dateSubString = subStrings(1) timeSubString = subStrings(2) deallocate(subStrings) - read(daySubString,*) day - else if(size(subStrings) == 1) then ! contains only a time- assume day is 0 + + call mpas_split_string(dateSubString, "-", subStrings) + + if(size(subStrings) == 3) then ! Contains year, month, and day + read(subStrings(1), *) year + read(subStrings(2), *) month + read(subStrings(3), *) day + else if(size(subStrings) == 2) then ! Contains month and day + year = 0 + read(subStrings(1), *) month + read(subStrings(2), *) day + else if(size(subStrings) == 1) then ! Contains day + year = 0 + month = 0 + read(subStrings(1), *) day + else ! Error? + year = 0 + month = 0 + day = 0 + !write(stderrUnit,*) 'ERROR: Invalid TimeInterval string ', trim(timeString) + end if + + deallocate(subStrings) + else if(size(subStrings) == 1) then ! contains only a time- assume year, month, and day are 0 timeSubString = subStrings(1) deallocate(subStrings) + year = 0 + month = 0 day = 0 else deallocate(subStrings) @@ -1138,6 +1278,16 @@ subroutine mpas_set_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt read(subStrings(2),*) min read(subStrings(3),*) sec deallocate(subStrings) + else if (size(subStrings) == 2) then + hour = 0 + read(subStrings(1),*) min + read(subStrings(2),*) sec + deallocate(subStrings) + else if (size(subStrings) == 1) then + hour = 0 + min = 0 + read(subStrings(1),*) sec + deallocate(subStrings) else deallocate(subStrings) if (present(ierr)) ierr = 1 @@ -1145,49 +1295,64 @@ subroutine mpas_set_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt return end if - call ESMF_TimeIntervalSet(interval % ti, D=day, H=hour, M=min, S=sec, Sn=numerator, Sd=denominator, rc=ierr) + call ESMF_TimeIntervalSet(interval % ti, YY=year, MM=month, D=day, H=hour, M=min, S_i8=sec, Sn=numerator, Sd=denominator, rc=ierr) else - call ESMF_TimeIntervalSet(interval % ti, D=DD, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr) + call ESMF_TimeIntervalSet(interval % ti, YY=YY, MM=MM, D=DD, H=H, M=M, S_i8=S_i8, S=S, Sn=S_n, Sd=S_d, rc=ierr) end if - ! verify that time interval is positive - call ESMF_TimeIntervalSet(zeroInterval % ti, D=0, H=0, M=0, S=0, rc=ierr) +! ! verify that time interval is positive +! call ESMF_TimeIntervalSet(zeroInterval % ti, D=0, H=0, M=0, S=0, rc=ierr) - if (present(ierr)) then - if (ierr == ESMF_SUCCESS) ierr = 0 - end if - - if (interval <= zeroInterval) then - if (present(ierr)) ierr = 1 - write(stderrUnit,*) 'ERROR: TimeInterval must be greater than zero: ', trim(timeString) !'ERROR: TimeInterval cannot be negative' - end if +! if (present(ierr)) then +! if (ierr == ESMF_SUCCESS) ierr = 0 +! end if +! if (interval <= zeroInterval) then +! if (present(ierr)) ierr = 1 +! write(stderrUnit,*) 'ERROR: TimeInterval must be greater than zero: ', trim(timeString) !'ERROR: TimeInterval cannot be negative' +! end if end subroutine mpas_set_timeInterval - subroutine mpas_get_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt, ierr) + subroutine mpas_get_timeInterval(interval, StartTimeIn, DD, H, M, S, S_n, S_d, S_i8, timeString, dt, ierr) ! TODO: add double-precision seconds implicit none type (MPAS_TimeInterval_type), intent(in) :: interval + type (MPAS_Time_type), intent(in), optional :: StartTimeIn + ! For time intervals that require months and/or years, ESMF needs to know the start + ! time to get a time interval in any format besides the string format. integer, intent(out), optional :: DD integer, intent(out), optional :: H integer, intent(out), optional :: M integer, intent(out), optional :: S integer, intent(out), optional :: S_n integer, intent(out), optional :: S_d + integer (kind=I8KIND), intent(out), optional :: S_i8 character (len=StrKIND), intent(out), optional :: timeString real (kind=RKIND), intent(out), optional :: dt integer, intent(out), optional :: ierr - integer :: days, seconds, sn, sd + integer :: days, sn, sd + integer (kind=I8KIND) :: seconds + - call ESMF_TimeIntervalGet(interval % ti, D=days, S=seconds, Sn=sn, Sd=sd, rc=ierr) + + if (present(StartTimeIn)) then + call ESMF_TimeIntervalGet(interval % ti, StartTimeIn=StartTimeIn%t, D=days, S_i8=seconds, Sn=sn, Sd=sd, rc=ierr) + else + if ( interval % ti % YR /= 0 .or. interval % ti % MM /= 0 ) then + if (present(ierr)) ierr = 1 + write(stderrUnit,*) 'ERROR: mpas_get_timeInterval cannnot return time interval information for an interval containing months and years without a startTimeIn argument.' + return + end if + call ESMF_TimeIntervalGet(interval % ti, D=days, S_i8=seconds, Sn=sn, Sd=sd, rc=ierr) + endif if (present(dt)) then dt = (days * 24 * 60 * 60) + seconds + (sn / sd) @@ -1212,6 +1377,10 @@ subroutine mpas_get_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt days = 0 end if + if (present(S_i8)) then + S_i8 = seconds + end if + if (present(S)) then S = seconds end if @@ -1221,6 +1390,9 @@ subroutine mpas_get_timeInterval(interval, DD, H, M, S, S_n, S_d, timeString, dt end if if (present(S_d)) then + if (sd == 0) then ! may only occur if (sn == 0)? + sd = 1 + end if S_d = sd end if @@ -1315,6 +1487,212 @@ type (MPAS_TimeInterval_type) function div_ti_n(ti, n) end function div_ti_n + !----------------------------------------------------------------------- + ! routine mpas_interval_division + ! + !> \brief This routine computes the number intervals that fit into another interval. + !> \author Michael Duda, Doug Jacobsen + !> \date 10/02/2014 + !> \details This routine is a wrapper to two different methods of computing + !> the number of intervals that fit into another interval. + !> + !----------------------------------------------------------------------- + subroutine mpas_interval_division(ref_time, num, den, n, rem) + + implicit none + + type (MPAS_Time_type), intent(in) :: ref_time + type (MPAS_TimeInterval_type), intent(in) :: num + type (MPAS_TimeInterval_type), intent(in) :: den + integer, intent(out) :: n + type (MPAS_TimeInterval_type), intent(out) :: rem + + type (MPAS_TimeInterval_type) :: newNum, newDen + integer :: days, secondsNum, secondsDen + integer (kind=I8KIND) :: seconds + + if ( num % ti % YR == 0 .and. num % ti % MM == 0 .and. den % ti % YR == 0 .and. den % ti % MM == 0 ) then + call mpas_interval_division_log(num, den, n, rem) + else + call mpas_interval_division_linear(ref_time, num, den, n, rem) + end if + + end subroutine mpas_interval_division + + !----------------------------------------------------------------------- + ! routine mpas_interval_division_log + ! + !> \brief This routine computes the number intervals that fit into another interval using a log search. + !> \author Michael Duda, Doug Jacobsen + !> \date 10/02/2014 + !> \details This routine computes the number of intervals that fit into + !> another time interval using a log search. It is preferred over the + !> _linear alternative, but only works when the intervals are in terms of days + !> or smaller. + !> + !----------------------------------------------------------------------- + subroutine mpas_interval_division_log(num, den, n, rem) + + implicit none + + type (MPAS_TimeInterval_type), intent(in) :: num + type (MPAS_TimeInterval_type), intent(in) :: den + integer, intent(out) :: n + type (MPAS_TimeInterval_type), intent(out) :: rem + + type (MPAS_TimeInterval_type) :: temp + type (MPAS_TimeInterval_type) :: zero + integer :: nn + + call mpas_set_timeInterval(zero, S=0) + + ! + ! If the numerator is smaller than the denominator, just return the numerator as the remainder + ! + if (num < den) then + n = 0 + rem = num + return + end if + + + ! + ! Avoid division by zero + ! + if (den == zero) then + write(stderrUnit,*) 'Error: Attempting to divide by zero.\n' + n = 0 + rem = zero + return + end if + + + ! + ! Begin by finding the smallest multiple of the denominator that is at least as large as the numerator and is also a power of two + ! + temp = den + nn = 1 + do while (temp <= num) + temp = temp * 2 + nn = nn * 2 + end do + + ! + ! Dividing by two, we're guaranteed that temp is at most the value of the numerator + ! + temp = temp / 2 + nn = nn / 2 + + ! + ! Work backwards to zero + ! + n = 0 + rem = num + do while (nn > 0) + if (temp <= rem) then + rem = rem - temp + n = n + nn + end if + nn = nn / 2 + temp = temp / 2 + end do + + end subroutine mpas_interval_division_log + + + !----------------------------------------------------------------------- + ! routine mpas_interval_division_linear + ! + !> \brief This routine computes the number intervals that fit into another interval using a linear search. + !> \author Michael Duda, Doug Jacobsen + !> \date 10/02/2014 + !> \details This routine computes the number of intervals that fit into + !> another time interval using a linear search. It is slower than the _log + !> alternative, but works when intervals contain months or longer interval + !> sections. + !> + !----------------------------------------------------------------------- + subroutine mpas_interval_division_linear(ref_time, num, den, n, rem) + + implicit none + + type (MPAS_Time_type), intent(in) :: ref_time + type (MPAS_TimeInterval_type), intent(in) :: num + type (MPAS_TimeInterval_type), intent(in) :: den + integer, intent(out) :: n + type (MPAS_TimeInterval_type), intent(out) :: rem + + integer :: m + + type (MPAS_Time_type) :: target_time + type (MPAS_Time_type) :: updated_time, mid_time + + type (MPAS_TimeInterval_type) :: temp, mid_int + type (MPAS_TimeInterval_type) :: zero + + target_time = ref_time + num + + updated_time = ref_time + den + + n = 0 + + ! If the denominator is larger than the numerator, return 0 intervals, + ! and the numerator as the remainder + if ( target_time < updated_time ) then + rem = num + return + end if + + ! One interval of den already fits into num + n = n + 1 + temp = den + + ! Search forward, doubling the interval each time. + do while (target_time > updated_time) + n = n * 2 + temp = den * n + updated_time = ref_time + temp + end do + + ! Setup midpoint of search + ! The last value of n puts updated_time after target_time, need to back off and find the final time. + n = n / 2 + m = n + mid_int = den * n + temp = mid_int + updated_time = ref_time + mid_int + temp + + ! Seach backward, halving the interval each time. + do while (target_time < updated_time) + m = m / 2 + temp = den * m + updated_time = ref_time + mid_int + temp + end do + + ! Final number of interavls is n + m + n = n + m + + ! Do a final linear search, just to ensure we aren't missing any divisions. + temp = den * n + updated_time = ref_time + temp + + do while (target_time > updated_time) + n = n + 1 + updated_time = updated_time + den + end do + + ! Here, if updated_time is larger than target time. Need to subtract den once, and compute remainder + if ( updated_time > target_time ) then + updated_time = updated_time - den + n = n - 1 + rem = target_time - updated_time + else + call mpas_set_timeInterval(rem, S=0) + end if + + return + end subroutine mpas_interval_division_linear + logical function eq_t_t(t1, t2) @@ -1622,7 +2000,104 @@ logical function isLeapYear(year) end function isLeapYear + !----------------------------------------------------------------------- + ! routine mpas_expand_string + ! + !> \brief This is a utility routine that expands a string with a timestamp. + !> \author Michael Duda, Doug Jacobsen + !> \date 07/23/2014 + !> \details This routine will take a time stamp, and a string as + !> input, and expand the string according to the time stamp provided. + !> $Y -> year + !> $M -> month + !> $D -> day + !> $d -> day of year + !> $h -> hour + !> $m -> minute + !> $s -> second + !> $g -> multi-grid level + !----------------------------------------------------------------------- + subroutine mpas_expand_string(timeStamp, inString, outString)!{{{ + + implicit none + + character (len=*), intent(in) :: timeStamp + character (len=*), intent(in) :: inString + character (len=StrKIND), intent(out) :: outString + + type (MPAS_Time_type) :: curTime + + integer :: i, curLen + integer :: year, month, day, hour, minute, second, DoY + + character (len=ShortStrKIND) :: timePart + character (len=ShortStrKIND) :: yearFormat + logical :: charExpand + + call mpas_set_time(curTime, dateTimeString=timeStamp) + + call mpas_get_time(curTime, YYYY=year) + + write(yearFormat, '(a,i10,a)') '(i0.',yearWidth,')' + + write(outString,*) '' + write(timePart,*) '' + + curLen = 0 + charExpand = .false. + do i = 1, len_trim(inString) + if (inString(i:i) == '$' ) then + charExpand = .true. + else if (inString(i:i) /= '$') then + if (charExpand) then + select case (inString(i:i)) + case ('Y') + call mpas_get_time(curTime, YYYY=year) + write(timePart, yearFormat) year + outString = trim(outString) // trim(timePart) + case ('M') + call mpas_get_time(curTime, MM=month) + write(timePart, '(i0.2)') month + outString = trim(outString) // trim(timePart) + case ('D') + call mpas_get_time(curTime, DD=day) + write(timePart, '(i0.2)') day + outString = trim(outString) // trim(timePart) + case ('d') + call mpas_get_time(curTime, DoY=DoY) + write(timePart, '(i0.3)') DoY + outString = trim(outString) // trim(timePart) + case ('h') + call mpas_get_time(curTime, H=hour) + write(timePart, '(i0.2)') hour + outString = trim(outString) // trim(timePart) + case ('m') + call mpas_get_time(curTime, M=minute) + write(timePart, '(i0.2)') minute + outString = trim(outString) // trim(timePart) + case ('s') + call mpas_get_time(curTime, S=second) + write(timePart, '(i0.2)') second + outString = trim(outString) // trim(timePart) +! case ('G') + ! Expands to multi-grid level + case default + write(stderrUnit, *) 'ERROR: mpas_expand_string option $', inString(i:i), ' is not a valid expansion character.' + call mpas_dmpar_global_abort('ERROR: mpas_timekeeping') + end select + + curLen = len_trim(outString) + charExpand = .false. + else + outString(curLen+1:curLen+1) = inString(i:i) + curLen = curLen+1 + end if + else + end if + end do + end subroutine mpas_expand_string!}}} + @@ -1635,8 +2110,6 @@ subroutine wrf_error_fatal(msg) character (len=*) :: msg - write(0,*) 'MPAS_TIMEKEEPING: '//trim(msg) - - stop + call mpas_dmpar_global_abort('ERROR: mpas_timekeeping: '//trim(msg)) end subroutine wrf_error_fatal diff --git a/src/framework/mpas_timer.F b/src/framework/mpas_timer.F index 79c0f7d6c1..afa26901cc 100644 --- a/src/framework/mpas_timer.F +++ b/src/framework/mpas_timer.F @@ -34,7 +34,7 @@ module mpas_timer type timer_node character (len=StrKIND) :: timer_name logical :: running, printable - integer :: levels, calls + integer :: levels, calls, nlen real (kind=RKIND) :: start_time, end_time, total_time real (kind=RKIND) :: max_time, min_time, avg_time real (kind=RKIND) :: efficiency @@ -74,13 +74,16 @@ subroutine mpas_timer_start(timer_name, clear_timer, timer_ptr)!{{{ 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 + character (len=len(timer_name)) :: trimed_name logical :: timer_added, timer_found, string_equal, check_flag type (timer_node), pointer :: current, temp - integer :: clock, hz, usecs + integer :: clock, hz, usecs, nlen + trimed_name = trim(timer_name) + nlen = len(trimed_name) #ifdef MPAS_TAU - call tau_start(timer_name) + call tau_start(trimed_name) #endif timer_added = .false. @@ -93,12 +96,13 @@ subroutine mpas_timer_start(timer_name, clear_timer, timer_ptr)!{{{ levels = 0 all_timers%timer_name = '' + all_timers%nlen = 0 current => all_timers%next nullify(current%next) else current => all_timers%next timer_search: do while ((.not.timer_found) .and. associated(current)) - string_equal = (trim(current%timer_name) == trim(timer_name)) + string_equal = (current%timer_name(1:current%nlen) == trimed_name) if(string_equal) then timer_found = .true. else @@ -121,7 +125,8 @@ subroutine mpas_timer_start(timer_name, clear_timer, timer_ptr)!{{{ current => timer_ptr nullify(timer_ptr%next) current%levels = levels - current%timer_name = timer_name + current%timer_name = trimed_name + current%nlen = nlen current%running = .false. current%total_time = 0.0 current%max_time = 0.0 @@ -149,7 +154,8 @@ subroutine mpas_timer_start(timer_name, clear_timer, timer_ptr)!{{{ if(timer_added .and. (.not.timer_found)) then current%levels = levels - current%timer_name = timer_name + current%timer_name = trimed_name + current%nlen = nlen current%running = .false. current%total_time = 0.0 current%max_time = 0.0 @@ -213,15 +219,18 @@ subroutine mpas_timer_stop(timer_name, timer_ptr)!{{{ 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 + character (len=len(timer_name)) :: trimed_name !< Trimed timer name type (timer_node), pointer :: current real (kind=RKIND) :: time_temp logical :: timer_found, string_equal, check_flag - integer :: clock, hz, usecs + integer :: clock, hz, usecs, nlen + trimed_name = trim(timer_name) + nlen = len(trimed_name) #ifdef MPAS_TAU - call tau_stop(timer_name) + call tau_stop(trimed_name) #endif timer_found = .false. @@ -236,7 +245,7 @@ subroutine mpas_timer_stop(timer_name, timer_ptr)!{{{ else if(.not. timer_found) then current => all_timers timer_find: do while(.not.timer_found .and. associated(current)) - string_equal = (trim(current%timer_name) == trim(timer_name)) + string_equal = (current%timer_name(1:current%nlen) == trimed_name) if(string_equal) then timer_found = .true. @@ -248,7 +257,7 @@ subroutine mpas_timer_stop(timer_name, timer_ptr)!{{{ if(.not.timer_found) then print *,' timer_stop :: timer_stop called with timer_name =', timer_name,' when timer has not been started.' - stop + call mpas_dmpar_global_abort('ERROR: in subroutine mpas_timer_stop()') endif if(current%running) then @@ -304,7 +313,7 @@ recursive subroutine mpas_timer_write(timer_ptr, total_ptr)!{{{ logical :: total_found, string_equals type (timer_node), pointer :: current, total real (kind=RKIND) :: percent - integer :: i + integer :: i, nlen total_found = .false. @@ -316,7 +325,7 @@ recursive subroutine mpas_timer_write(timer_ptr, total_ptr)!{{{ if(present(timer_ptr) .and. (.not.present(total_ptr))) then print *,'timer_write :: timer_ptr valid, but total_ptr is not assigned.' - stop + call mpas_dmpar_global_abort('ERROR: in subroutine mpas_timer_write()') else if(present(timer_ptr)) then tname = '' do i=0,timer_ptr%levels+2 @@ -342,7 +351,7 @@ recursive subroutine mpas_timer_write(timer_ptr, total_ptr)!{{{ total => all_timers find_total: do while((.not.total_found) .and. associated(total)) - string_equals = (trim(total%timer_name) == trim("total time")) + string_equals = (total%timer_name(1:total%nlen) == "total time") if(string_equals) then total_found = .true. else @@ -352,7 +361,7 @@ recursive subroutine mpas_timer_write(timer_ptr, total_ptr)!{{{ if(.not.total_found) then print *,' timer_write :: no timer named "total time" found.' - stop + call mpas_dmpar_global_abort('ERROR: in subroutine mpas_timer_write()') end if write(stdoutUnit,'(3x, a10, 24x, a15, a10, a13, a15, a15, a12, a12)') 'timer_name', 'total', 'calls', 'min', 'max', & @@ -363,8 +372,8 @@ recursive subroutine mpas_timer_write(timer_ptr, total_ptr)!{{{ current => all_timers print_timers: do while(associated(current)) - string_equals = (trim(current%timer_name) == trim("total time")) - string_equals = string_equals .or. (trim(current%timer_name) == trim(" ")) + string_equals = (current%timer_name(1:current%nlen) == "total time") + string_equals = string_equals .or. (current%timer_name(1:current%nlen) == "") if(.not.string_equals) then call mpas_timer_write(current, total) diff --git a/src/framework/pool_hash.c b/src/framework/pool_hash.c new file mode 100644 index 0000000000..a0930e91ae --- /dev/null +++ b/src/framework/pool_hash.c @@ -0,0 +1,23 @@ +#include + +#ifdef UNDERSCORE +#define pool_hash pool_hash_ +#else +#ifdef DOUBLEUNDERSCORE +#define pool_hash pool_hash__ +#endif +#endif + +void pool_hash(int* hash, char* key, int* len) +{ + int i; + unsigned int whash; + + whash = 0; + + for (i=0; i<(*len); i++) { + whash += (unsigned int)key[i]; + } + + *hash = (int)(whash & 0x7fffffff); +} diff --git a/src/framework/pool_subroutines.inc b/src/framework/pool_subroutines.inc new file mode 100644 index 0000000000..fca1b1a3a1 --- /dev/null +++ b/src/framework/pool_subroutines.inc @@ -0,0 +1,5615 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! POOL SUBROUTINES +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +!----------------------------------------------------------------------- +! routine mpas_pool_set_error_level +! +!> \brief MPAS Pool Error level set routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine sets the internal error level for pools. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_set_error_level(newErrorLevel) !{{{ + + implicit none + + integer, intent(in) :: newErrorLevel + + currentErrorLevel = newErrorLevel + + end subroutine mpas_pool_set_error_level !}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_get_error_level +! +!> \brief MPAS Pool Error level get function +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine returns the internal error level for pools. +! +!----------------------------------------------------------------------- + integer function mpas_pool_get_error_level() !{{{ + + implicit none + + mpas_pool_get_error_level = currentErrorLevel + + end function mpas_pool_get_error_level !}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_create_pool +! +!> \brief MPAS Pool creation routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine will create a new empty pool and associate newPool to this new +!> pool location. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_create_pool(newPool, poolSize)!{{{ + + implicit none + + type (mpas_pool_type), pointer :: newPool + integer, intent(in), optional :: poolSize + + + allocate(newPool) + + if (present(poolSize)) then + newPool % size = poolSize + else + newPool % size = MPAS_POOL_TABLE_SIZE + end if + allocate(newPool % table(newPool % size)) + + end subroutine mpas_pool_create_pool!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_destroy_pool +! +!> \brief MPAS Pool deallocation routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine will destroy a pool associated with inPool. +! +!----------------------------------------------------------------------- + recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ + + implicit none + + type (mpas_pool_type), pointer :: inPool + + integer :: i, j + type (mpas_pool_member_type), pointer :: ptr + type (mpas_pool_data_type), pointer :: dptr + + + do i=1,inPool % size + + ptr => inPool % table(i) % head + do while(associated(inPool % table(i) % head)) + ptr => inPool % table(i) % head + inPool % table(i) % head => inPool % table(i) % head % next + + if (ptr % contentsType == MPAS_POOL_DIMENSION) then + + if (ptr % data % contentsDims > 0) then + deallocate(ptr % data % simple_int_arr) + else + deallocate(ptr % data % simple_int) + end if + + else if (ptr % contentsType == MPAS_POOL_CONFIG) then + + dptr => ptr % data + + if (dptr % contentsType == MPAS_POOL_REAL) then + deallocate(dptr % simple_real) + else if (dptr % contentsType == MPAS_POOL_INTEGER) then + deallocate(dptr % simple_int) + else if (dptr % contentsType == MPAS_POOL_CHARACTER) then + deallocate(dptr % simple_char) + else if (dptr % contentsType == MPAS_POOL_LOGICAL) then + deallocate(dptr % simple_logical) + end if + + else if (ptr % contentsType == MPAS_POOL_FIELD) then + + dptr => ptr % data + + ! Do this through brute force... + if (associated(dptr % r0)) then + if (associated(dptr % r0 % ioinfo)) then + deallocate(dptr % r0 % ioinfo) + end if + + deallocate(dptr % r0) + else if (associated(dptr % r1)) then + if (associated(dptr % r1 % ioinfo)) then + deallocate(dptr % r1 % ioinfo) + end if + + if (associated(dptr % r1 % array)) then + deallocate(dptr % r1 % array) + end if + + deallocate(dptr % r1) + else if (associated(dptr % r2)) then + if (associated(dptr % r2 % ioinfo)) then + deallocate(dptr % r2 % ioinfo) + end if + + if (associated(dptr % r2 % array)) then + deallocate(dptr % r2 % array) + end if + + deallocate(dptr % r2) + else if (associated(dptr % r3)) then + if (associated(dptr % r3 % ioinfo)) then + deallocate(dptr % r3 % ioinfo) + end if + + if (associated(dptr % r3 % array)) then + deallocate(dptr % r3 % array) + end if + + deallocate(dptr % r3) + else if (associated(dptr % r4)) then + if (associated(dptr % r4 % ioinfo)) then + deallocate(dptr % r4 % ioinfo) + end if + + if (associated(dptr % r4 % array)) then + deallocate(dptr % r4 % array) + end if + + deallocate(dptr % r4) + else if (associated(dptr % r5)) then + if (associated(dptr % r5 % ioinfo)) then + deallocate(dptr % r5 % ioinfo) + end if + + if (associated(dptr % r5 % array)) then + deallocate(dptr % r5 % array) + end if + + deallocate(dptr % r5) + else if (associated(dptr % i0)) then + if (associated(dptr % i0 % ioinfo)) then + deallocate(dptr % i0 % ioinfo) + end if + + deallocate(dptr % i0) + else if (associated(dptr % i1)) then + if (associated(dptr % i1 % ioinfo)) then + deallocate(dptr % i1 % ioinfo) + end if + + if (associated(dptr % i1 % array)) then + deallocate(dptr % i1 % array) + end if + + deallocate(dptr % i1) + else if (associated(dptr % i2)) then + if (associated(dptr % i2 % ioinfo)) then + deallocate(dptr % i2 % ioinfo) + end if + + if (associated(dptr % i2 % array)) then + deallocate(dptr % i2 % array) + end if + + deallocate(dptr % i2) + else if (associated(dptr % i3)) then + if (associated(dptr % i3 % ioinfo)) then + deallocate(dptr % i3 % ioinfo) + end if + + if (associated(dptr % i3 % array)) then + deallocate(dptr % i3 % array) + end if + + deallocate(dptr % i3) + else if (associated(dptr % c0)) then + if (associated(dptr % c0 % ioinfo)) then + deallocate(dptr % c0 % ioinfo) + end if + + deallocate(dptr % c0) + else if (associated(dptr % c1)) then + if (associated(dptr % c1 % ioinfo)) then + deallocate(dptr % c1 % ioinfo) + end if + + if (associated(dptr % c1 % array)) then + deallocate(dptr % c1 % array) + end if + + deallocate(dptr % c1) + else if (associated(dptr % l0)) then + if (associated(dptr % l0 % ioinfo)) then + deallocate(dptr % l0 % ioinfo) + end if + + deallocate(dptr % l0) + else if (associated(dptr % r0a)) then + do j=1,dptr % contentsTimeLevs + dptr % r0 => dptr % r0a(j) + call mpas_deallocate_field(dptr % r0) + end do + deallocate(dptr % r0a) + else if (associated(dptr % r0a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % r0a(j) % ioinfo)) then + deallocate(dptr % r0a(j) % ioinfo) + end if + end do + deallocate(dptr % r0a) + else if (associated(dptr % r1a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % r1a(j) % ioinfo)) then + deallocate(dptr % r1a(j) % ioinfo) + end if + + if (associated(dptr % r1a(j) % array)) then + deallocate(dptr % r1a(j) % array) + end if + end do + deallocate(dptr % r1a) + else if (associated(dptr % r2a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % r2a(j) % ioinfo)) then + deallocate(dptr % r2a(j) % ioinfo) + end if + + if (associated(dptr % r2a(j) % array)) then + deallocate(dptr % r2a(j) % array) + end if + end do + deallocate(dptr % r2a) + else if (associated(dptr % r3a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % r3a(j) % ioinfo)) then + deallocate(dptr % r3a(j) % ioinfo) + end if + + if (associated(dptr % r3a(j) % array)) then + deallocate(dptr % r3a(j) % array) + end if + end do + deallocate(dptr % r3a) + else if (associated(dptr % r4a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % r4a(j) % ioinfo)) then + deallocate(dptr % r4a(j) % ioinfo) + end if + + if (associated(dptr % r4a(j) % array)) then + deallocate(dptr % r4a(j) % array) + end if + end do + deallocate(dptr % r4a) + else if (associated(dptr % r5a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % r5a(j) % ioinfo)) then + deallocate(dptr % r5a(j) % ioinfo) + end if + + if (associated(dptr % r5a(j) % array)) then + deallocate(dptr % r5a(j) % array) + end if + end do + deallocate(dptr % r5a) + else if (associated(dptr % i0a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % i0a(j) % ioinfo)) then + deallocate(dptr % i0a(j) % ioinfo) + end if + end do + deallocate(dptr % i0a) + else if (associated(dptr % i1a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % i1a(j) % ioinfo)) then + deallocate(dptr % i1a(j) % ioinfo) + end if + + if (associated(dptr % i1a(j) % array)) then + deallocate(dptr % i1a(j) % array) + end if + end do + deallocate(dptr % i1a) + else if (associated(dptr % i2a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % i2a(j) % ioinfo)) then + deallocate(dptr % i2a(j) % ioinfo) + end if + + if (associated(dptr % i2a(j) % array)) then + deallocate(dptr % i2a(j) % array) + end if + end do + deallocate(dptr % i2a) + else if (associated(dptr % i3a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % i3a(j) % ioinfo)) then + deallocate(dptr % i3a(j) % ioinfo) + end if + + if (associated(dptr % i3a(j) % array)) then + deallocate(dptr % i3a(j) % array) + end if + end do + deallocate(dptr % i3a) + else if (associated(dptr % c0a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % c0a(j) % ioinfo)) then + deallocate(dptr % c0a(j) % ioinfo) + end if + end do + deallocate(dptr % c0a) + else if (associated(dptr % c1a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % c1a(j) % ioinfo)) then + deallocate(dptr % c1a(j) % ioinfo) + end if + + if (associated(dptr % c1a(j) % array)) then + deallocate(dptr % c1a(j) % array) + end if + end do + deallocate(dptr % c1a) + else if (associated(dptr % l0a)) then + do j=1,dptr % contentsTimeLevs + if (associated(dptr % l0a(j) % ioinfo)) then + deallocate(dptr % l0a(j) % ioinfo) + end if + end do + deallocate(dptr % l0a) + else + call pool_mesg('While destroying pool, member '//trim(ptr % key)//' has no valid field pointers.') + end if + + else if (ptr % contentsType == MPAS_POOL_SUBPOOL) then + + call mpas_pool_destroy_pool(ptr % data % p) + + end if + deallocate(ptr % data) + deallocate(ptr) + end do + + end do + + deallocate(inPool % table) + deallocate(inPool) + + end subroutine mpas_pool_destroy_pool!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_empty_pool +! +!> \brief MPAS Pool empty routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine will remove all memebers from within a pool associated with inPool. +! +!----------------------------------------------------------------------- + recursive subroutine mpas_pool_empty_pool(inPool)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + + integer :: i + type (mpas_pool_member_type), pointer :: ptr + + + do i=1,inPool % size + + ptr => inPool % table(i) % head + do while(associated(inPool % table(i) % head)) + ptr => inPool % table(i) % head + inPool % table(i) % head => inPool % table(i) % head % next + if (ptr % contentsType == MPAS_POOL_DIMENSION) then + if (ptr % data % contentsDims > 0) then + deallocate(ptr % data % simple_int_arr) + else + deallocate(ptr % data % simple_int) + end if + else if (ptr % contentsType == MPAS_POOL_CONFIG) then + if (ptr % data % contentsType == MPAS_POOL_REAL) then + deallocate(ptr % data % simple_real) + else if (ptr % data % contentsType == MPAS_POOL_INTEGER) then + deallocate(ptr % data % simple_int) + else if (ptr % data % contentsType == MPAS_POOL_CHARACTER) then + deallocate(ptr % data % simple_char) + else if (ptr % data % contentsType == MPAS_POOL_LOGICAL) then + deallocate(ptr % data % simple_logical) + end if + else if (ptr % contentsType == MPAS_POOL_PACKAGE) then + deallocate(ptr % data % simple_logical) + else if (ptr % contentsType == MPAS_POOL_SUBPOOL) then + call mpas_pool_empty_pool(ptr % data % p) + deallocate(ptr % data % p) + end if + deallocate(ptr) + end do + + end do + + inPool % iteratorIndex = 1 + nullify(inPool % iterator) + + end subroutine mpas_pool_empty_pool!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_clone_pool +! +!> \brief MPAS Pool clone routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine assumes destPool is an empty pool. It will clone all of the members +!> from srcPool into destPool. +! +!----------------------------------------------------------------------- + recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels)!{{{ + + implicit none + + type (mpas_pool_type), pointer :: srcPool + type (mpas_pool_type), pointer :: destPool + integer, intent(in), optional :: overrideTimeLevels + + + integer :: i, j, newTimeLevels, minTimeLevels + type (mpas_pool_member_type), pointer :: ptr + type (mpas_pool_data_type), pointer :: dptr + type (mpas_pool_member_type), pointer :: newmem + + newTimeLevels = -1 + + if (present(overrideTimeLevels)) then + newTimeLevels = overrideTimeLevels + + if (newTimeLevels < 1) then + call mpas_pool_set_error_level(MPAS_POOL_FATAL) + call pool_mesg('ERROR in mpas_pool_clone_pool: Input time levels cannot be less than 1.') + end if + end if + + !TODO: Make use of overrideTimeLevels. This routine needs to create a new set of time levels. + +!TODO: should we force destPool to have the same table size as srcPool? + + do i=1,srcPool % size + + ptr => srcPool % table(i) % head + do while(associated(ptr)) + + allocate(newmem) + newmem % key = ptr % key + newmem % keyLen = ptr % keyLen + newmem % contentsType = ptr % contentsType + allocate(newmem % data) + newmem % data % contentsType = ptr % data % contentsType + newmem % data % contentsDims = ptr % data % contentsDims + if (newTimeLevels /= -1) then + newmem % data % contentsTimeLevs = newTimeLevels + else + newmem % data % contentsTimeLevs = ptr % data % contentsTimeLevs + end if + + if (ptr % contentsType == MPAS_POOL_DIMENSION) then + + if (ptr % data % contentsDims > 0) then + allocate(newmem % data % simple_int_arr(size(ptr % data % simple_int_arr))) + newmem % data % simple_int_arr(:) = ptr % data % simple_int_arr(:) + else + allocate(newmem % data % simple_int) + newmem % data % simple_int = ptr % data % simple_int + end if + + else if (ptr % contentsType == MPAS_POOL_CONFIG) then + + dptr => ptr % data + + if (dptr % contentsType == MPAS_POOL_REAL) then + allocate(newmem % data % simple_real) + newmem % data % simple_real = dptr % simple_real + else if (dptr % contentsType == MPAS_POOL_INTEGER) then + allocate(newmem % data % simple_int) + newmem % data % simple_int = dptr % simple_int + else if (dptr % contentsType == MPAS_POOL_CHARACTER) then + allocate(newmem % data % simple_char) + newmem % data % simple_char = dptr % simple_char + else if (dptr % contentsType == MPAS_POOL_LOGICAL) then + allocate(newmem % data % simple_logical) + newmem % data % simple_logical = dptr % simple_logical + end if + + else if (ptr % contentsType == MPAS_POOL_FIELD) then + + dptr => ptr % data + + ! Do this through brute force... + if (associated(dptr % r0)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r0a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r0, newmem % data % r0) + newmem % data % r0a(j) = newmem % data % r0 + deallocate(newmem % data % r0) + end do + else + call mpas_duplicate_field(dptr % r0, newmem % data % r0) + end if + else if (associated(dptr % r1)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r1a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r1, newmem % data % r1) + newmem % data % r1a(j) = newmem % data % r1 + deallocate(newmem % data % r1) + end do + else + call mpas_duplicate_field(dptr % r1, newmem % data % r1) + end if + else if (associated(dptr % r2)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r2a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r2, newmem % data % r2) + newmem % data % r2a(j) = newmem % data % r2 + deallocate(newmem % data % r2) + end do + else + call mpas_duplicate_field(dptr % r2, newmem % data % r2) + end if + else if (associated(dptr % r3)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r3a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r3, newmem % data % r3) + newmem % data % r3a(j) = newmem % data % r3 + deallocate(newmem % data % r3) + end do + else + call mpas_duplicate_field(dptr % r3, newmem % data % r3) + end if + else if (associated(dptr % r4)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r4a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r4, newmem % data % r4) + newmem % data % r4a(j) = newmem % data % r4 + deallocate(newmem % data % r4) + end do + else + call mpas_duplicate_field(dptr % r4, newmem % data % r4) + end if + else if (associated(dptr % r5)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r5a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r5, newmem % data % r5) + newmem % data % r5a(j) = newmem % data % r5 + deallocate(newmem % data % r5) + end do + else + call mpas_duplicate_field(dptr % r5, newmem % data % r5) + end if + else if (associated(dptr % i0)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % i0a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % i0, newmem % data % i0) + newmem % data % i0a(j) = newmem % data % i0 + deallocate(newmem % data % i0) + end do + else + call mpas_duplicate_field(dptr % i0, newmem % data % i0) + end if + else if (associated(dptr % i1)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % i1a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % i1, newmem % data % i1) + newmem % data % i1a(j) = newmem % data % i1 + deallocate(newmem % data % i1) + end do + else + call mpas_duplicate_field(dptr % i1, newmem % data % i1) + end if + else if (associated(dptr % i2)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % i2a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % i2, newmem % data % i2) + newmem % data % i2a(j) = newmem % data % i2 + deallocate(newmem % data % i2) + end do + else + call mpas_duplicate_field(dptr % i2, newmem % data % i2) + end if + else if (associated(dptr % i3)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % i3a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % i3, newmem % data % i3) + newmem % data % i3a(j) = newmem % data % i3 + deallocate(newmem % data % i3) + end do + else + call mpas_duplicate_field(dptr % i3, newmem % data % i3) + end if + else if (associated(dptr % c0)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % c0a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % c0, newmem % data % c0) + newmem % data % c0a(j) = newmem % data % c0 + deallocate(newmem % data % c0) + end do + else + call mpas_duplicate_field(dptr % c0, newmem % data % c0) + end if + else if (associated(dptr % c1)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % c1a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % c1, newmem % data % c1) + newmem % data % c1a(j) = newmem % data % c1 + deallocate(newmem % data % c1) + end do + else + call mpas_duplicate_field(dptr % c1, newmem % data % c1) + end if + else if (associated(dptr % l0)) then + if (newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % l0a(newmem % data % contentsTimeLevs)) + do j = 1, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % l0, newmem % data % l0) + newmem % data % l0a(j) = newmem % data % l0 + deallocate(newmem % data % l0) + end do + else + call mpas_duplicate_field(dptr % l0, newmem % data % l0) + end if + else if (associated(dptr % r0a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r0a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % r0a(j), newmem % data % r0) + newmem % data % r0a(j) = newmem % data % r0 + deallocate(newmem % data % r0) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r0a(dptr % contentsTimeLevs), newmem % data % r0) + newmem % data % r0a(j) = newmem % data % r0 + deallocate(newmem % data % r0) + end do + else + call mpas_duplicate_field(dptr % r0a(1), newmem % data % r0) + end if + else if (associated(dptr % r1a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r1a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % r1a(j), newmem % data % r1) + newmem % data % r1a(j) = newmem % data % r1 + deallocate(newmem % data % r1) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r1a(dptr % contentsTimeLevs), newmem % data % r1) + newmem % data % r1a(j) = newmem % data % r1 + deallocate(newmem % data % r1) + end do + else + call mpas_duplicate_field(dptr % r1a(1), newmem % data % r1) + end if + else if (associated(dptr % r2a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r2a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % r2a(j), newmem % data % r2) + newmem % data % r2a(j) = newmem % data % r2 + deallocate(newmem % data % r2) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r2a(dptr % contentsTimeLevs), newmem % data % r2) + newmem % data % r2a(j) = newmem % data % r2 + deallocate(newmem % data % r2) + end do + else + call mpas_duplicate_field(dptr % r2a(1), newmem % data % r2) + end if + else if (associated(dptr % r3a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r3a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % r3a(j), newmem % data % r3) + newmem % data % r3a(j) = newmem % data % r3 + deallocate(newmem % data % r3) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r3a(dptr % contentsTimeLevs), newmem % data % r3) + newmem % data % r3a(j) = newmem % data % r3 + deallocate(newmem % data % r3) + end do + else + call mpas_duplicate_field(dptr % r3a(1), newmem % data % r3) + end if + else if (associated(dptr % r4a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r4a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % r4a(j), newmem % data % r4) + newmem % data % r4a(j) = newmem % data % r4 + deallocate(newmem % data % r4) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r4a(dptr % contentsTimeLevs), newmem % data % r4) + newmem % data % r4a(j) = newmem % data % r4 + deallocate(newmem % data % r4) + end do + else + call mpas_duplicate_field(dptr % r4a(1), newmem % data % r4) + end if + else if (associated(dptr % r5a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % r5a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % r5a(j), newmem % data % r5) + newmem % data % r5a(j) = newmem % data % r5 + deallocate(newmem % data % r5) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % r5a(dptr % contentsTimeLevs), newmem % data % r5) + newmem % data % r5a(j) = newmem % data % r5 + deallocate(newmem % data % r5) + end do + else + call mpas_duplicate_field(dptr % r5a(1), newmem % data % r5) + end if + else if (associated(dptr % i0a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % i0a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % i0a(j), newmem % data % i0) + newmem % data % i0a(j) = newmem % data % i0 + deallocate(newmem % data % i0) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % i0a(dptr % contentsTimeLevs), newmem % data % i0) + newmem % data % i0a(j) = newmem % data % i0 + deallocate(newmem % data % i0) + end do + else + call mpas_duplicate_field(dptr % i0a(1), newmem % data % i0) + end if + else if (associated(dptr % i1a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % i1a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % i1a(j), newmem % data % i1) + newmem % data % i1a(j) = newmem % data % i1 + deallocate(newmem % data % i1) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % i1a(dptr % contentsTimeLevs), newmem % data % i1) + newmem % data % i1a(j) = newmem % data % i1 + deallocate(newmem % data % i1) + end do + else + call mpas_duplicate_field(dptr % i1a(1), newmem % data % i1) + end if + else if (associated(dptr % i2a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % i2a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % i2a(j), newmem % data % i2) + newmem % data % i2a(j) = newmem % data % i2 + deallocate(newmem % data % i2) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % i2a(dptr % contentsTimeLevs), newmem % data % i2) + newmem % data % i2a(j) = newmem % data % i2 + deallocate(newmem % data % i2) + end do + else + call mpas_duplicate_field(dptr % i2a(1), newmem % data % i2) + end if + else if (associated(dptr % i3a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % i3a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % i3a(j), newmem % data % i3) + newmem % data % i3a(j) = newmem % data % i3 + deallocate(newmem % data % i3) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % i3a(dptr % contentsTimeLevs), newmem % data % i3) + newmem % data % i3a(j) = newmem % data % i3 + deallocate(newmem % data % i3) + end do + else + call mpas_duplicate_field(dptr % i3a(1), newmem % data % i3) + end if + else if (associated(dptr % c0a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % c0a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % c0a(j), newmem % data % c0) + newmem % data % c0a(j) = newmem % data % c0 + deallocate(newmem % data % c0) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % c0a(dptr % contentsTimeLevs), newmem % data % c0) + newmem % data % c0a(j) = newmem % data % c0 + deallocate(newmem % data % c0) + end do + else + call mpas_duplicate_field(dptr % c0a(1), newmem % data % c0) + end if + else if (associated(dptr % c1a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % c1a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % c1a(j), newmem % data % c1) + newmem % data % c1a(j) = newmem % data % c1 + deallocate(newmem % data % c1) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % c1a(dptr % contentsTimeLevs), newmem % data % c1) + newmem % data % c1a(j) = newmem % data % c1 + deallocate(newmem % data % c1) + end do + else + call mpas_duplicate_field(dptr % c1a(1), newmem % data % c1) + end if + else if (associated(dptr % l0a)) then + if ( newmem % data % contentsTimeLevs > 1) then + allocate(newmem % data % l0a(newmem % data % contentsTimeLevs)) + minTimeLevels = min(dptr % contentsTimeLevs, newmem % data % contentsTimeLevs) + do j = 1, minTimeLevels + call mpas_duplicate_field(dptr % l0a(j), newmem % data % l0) + newmem % data % l0a(j) = newmem % data % l0 + deallocate(newmem % data % l0) + end do + + do j = minTimeLevels, newmem % data % contentsTimeLevs + call mpas_duplicate_field(dptr % l0a(dptr % contentsTimeLevs), newmem % data % l0) + newmem % data % l0a(j) = newmem % data % l0 + deallocate(newmem % data % l0) + end do + else + call mpas_duplicate_field(dptr % l0a(1), newmem % data % l0) + end if + else + call pool_mesg('While cloning pool, member '//trim(ptr % key)//' has no valid field pointers.') + end if + + else if (ptr % contentsType == MPAS_POOL_SUBPOOL) then + + call mpas_pool_create_pool(newmem % data % p, poolSize = ptr % data % p % size) + call mpas_pool_clone_pool(ptr % data % p, newmem % data % p) + + end if + + if (.not. pool_add_member(destPool, newmem % key, newmem)) then + call pool_mesg('Error: Had problems adding '//trim(newmem % key)//' to clone of pool.') + end if + + ptr => ptr % next + end do + + end do + + end subroutine mpas_pool_clone_pool!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_copy_pool +! +!> \brief MPAS Pool copy routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine assumes srcPool and destPool have identical members. It will +!> copy the data from the members of srcPool into the members of destPool. +! +!----------------------------------------------------------------------- + recursive subroutine mpas_pool_copy_pool(srcPool, destPool)!{{{ + + implicit none + + type (mpas_pool_type), pointer :: srcPool + type (mpas_pool_type), pointer :: destPool + + + integer :: i, j + type (mpas_pool_member_type), pointer :: ptr + type (mpas_pool_data_type), pointer :: dptr + type (mpas_pool_data_type), pointer :: mem + + do i=1,srcPool % size + + ptr => srcPool % table(i) % head + do while(associated(ptr)) + + if (ptr % contentsType == MPAS_POOL_DIMENSION) then + + mem => pool_get_member(destPool, ptr % key, MPAS_POOL_DIMENSION) + if (.not. associated(mem)) then + call mpas_pool_set_error_level(MPAS_POOL_FATAL) + call pool_mesg('ERROR: Destination pool does not contain member '//trim(ptr % key)//'.') + end if + if (ptr % data % contentsDims > 0) then + mem % simple_int_arr(:) = ptr % data % simple_int_arr(:) + else + mem % simple_int = ptr % data % simple_int + end if + + else if (ptr % contentsType == MPAS_POOL_CONFIG) then + + dptr => ptr % data + + mem => pool_get_member(destPool, ptr % key, MPAS_POOL_CONFIG) + if (dptr % contentsType == MPAS_POOL_REAL) then + mem % simple_real = dptr % simple_real + else if (dptr % contentsType == MPAS_POOL_INTEGER) then + mem % simple_int = dptr % simple_int + else if (dptr % contentsType == MPAS_POOL_CHARACTER) then + mem % simple_char = dptr % simple_char + else if (dptr % contentsType == MPAS_POOL_LOGICAL) then + mem % simple_logical = dptr % simple_logical + end if + + else if (ptr % contentsType == MPAS_POOL_FIELD) then + + dptr => ptr % data + + ! Do this through brute force... + mem => pool_get_member(destPool, ptr % key, MPAS_POOL_FIELD) + if (associated(dptr % r0)) then + call mpas_duplicate_field(dptr % r0, mem % r0, copy_array_only=.true.) + else if (associated(dptr % r1)) then + call mpas_duplicate_field(dptr % r1, mem % r1, copy_array_only=.true.) + else if (associated(dptr % r2)) then + call mpas_duplicate_field(dptr % r2, mem % r2, copy_array_only=.true.) + else if (associated(dptr % r3)) then + call mpas_duplicate_field(dptr % r3, mem % r3, copy_array_only=.true.) + else if (associated(dptr % r4)) then + call mpas_duplicate_field(dptr % r4, mem % r4, copy_array_only=.true.) + else if (associated(dptr % r5)) then + call mpas_duplicate_field(dptr % r5, mem % r5, copy_array_only=.true.) + else if (associated(dptr % i0)) then + call mpas_duplicate_field(dptr % i0, mem % i0, copy_array_only=.true.) + else if (associated(dptr % i1)) then + call mpas_duplicate_field(dptr % i1, mem % i1, copy_array_only=.true.) + else if (associated(dptr % i2)) then + call mpas_duplicate_field(dptr % i2, mem % i2, copy_array_only=.true.) + else if (associated(dptr % i3)) then + call mpas_duplicate_field(dptr % i3, mem % i3, copy_array_only=.true.) + else if (associated(dptr % c0)) then + call mpas_duplicate_field(dptr % c0, mem % c0, copy_array_only=.true.) + else if (associated(dptr % c1)) then + call mpas_duplicate_field(dptr % c1, mem % c1, copy_array_only=.true.) + else if (associated(dptr % l0)) then + call mpas_duplicate_field(dptr % l0, mem % l0, copy_array_only=.true.) + else if (associated(dptr % r0a)) then + do j=1,mem % contentsTimeLevs + mem % r0 => mem % r0a(j) + call mpas_duplicate_field(dptr % r0a(j), mem % r0, copy_array_only=.true.) + nullify(mem % r0) + end do + else if (associated(dptr % r1a)) then + do j=1,mem % contentsTimeLevs + mem % r1 => mem % r1a(j) + call mpas_duplicate_field(dptr % r1a(j), mem % r1, copy_array_only=.true.) + nullify(mem % r1) + end do + else if (associated(dptr % r2a)) then + do j=1,mem % contentsTimeLevs + mem % r2 => mem % r2a(j) + call mpas_duplicate_field(dptr % r2a(j), mem % r2, copy_array_only=.true.) + nullify(mem % r2) + end do + else if (associated(dptr % r3a)) then + do j=1,mem % contentsTimeLevs + mem % r3 => mem % r3a(j) + call mpas_duplicate_field(dptr % r3a(j), mem % r3, copy_array_only=.true.) + nullify(mem % r3) + end do + else if (associated(dptr % r4a)) then + do j=1,mem % contentsTimeLevs + mem % r4 => mem % r4a(j) + call mpas_duplicate_field(dptr % r4a(j), mem % r4, copy_array_only=.true.) + nullify(mem % r4) + end do + else if (associated(dptr % r5a)) then + do j=1,mem % contentsTimeLevs + mem % r5 => mem % r5a(j) + call mpas_duplicate_field(dptr % r5a(j), mem % r5, copy_array_only=.true.) + nullify(mem % r5) + end do + else if (associated(dptr % i0a)) then + do j=1,mem % contentsTimeLevs + mem % i0 => mem % i0a(j) + call mpas_duplicate_field(dptr % i0a(j), mem % i0, copy_array_only=.true.) + nullify(mem % i0) + end do + else if (associated(dptr % i1a)) then + do j=1,mem % contentsTimeLevs + mem % i1 => mem % i1a(j) + call mpas_duplicate_field(dptr % i1a(j), mem % i1, copy_array_only=.true.) + nullify(mem % i1) + end do + else if (associated(dptr % i2a)) then + do j=1,mem % contentsTimeLevs + mem % i2 => mem % i2a(j) + call mpas_duplicate_field(dptr % i2a(j), mem % i2, copy_array_only=.true.) + nullify(mem % i2) + end do + else if (associated(dptr % i3a)) then + do j=1,mem % contentsTimeLevs + mem % i3 => mem % i3a(j) + call mpas_duplicate_field(dptr % i3a(j), mem % i3, copy_array_only=.true.) + nullify(mem % i3) + end do + else if (associated(dptr % c0a)) then + do j=1,mem % contentsTimeLevs + mem % c0 => mem % c0a(j) + call mpas_duplicate_field(dptr % c0a(j), mem % c0, copy_array_only=.true.) + nullify(mem % c0) + end do + else if (associated(dptr % c1a)) then + do j=1,mem % contentsTimeLevs + mem % c1 => mem % c1a(j) + call mpas_duplicate_field(dptr % c1a(j), mem % c1, copy_array_only=.true.) + nullify(mem % c1) + end do + else if (associated(dptr % l0a)) then + do j=1,mem % contentsTimeLevs + mem % l0 => mem % l0a(j) + call mpas_duplicate_field(dptr % l0a(j), mem % l0, copy_array_only=.true.) + nullify(mem % l0) + end do + else + call pool_mesg('While copying pool, member '//trim(ptr % key)//' has no valid field pointers.') + end if + + else if (ptr % contentsType == MPAS_POOL_SUBPOOL) then + + mem => pool_get_member(destPool, ptr % key, MPAS_POOL_SUBPOOL) + call mpas_pool_copy_pool(ptr % data % p, mem % p) + + end if + + ptr => ptr % next + end do + + end do + + end subroutine mpas_pool_copy_pool!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_initialize_time_levels +! +!> \brief MPAS Pool copy routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine copies the data from the first time level of every field into +!> all subsequent time levels, to initialize them with real values. +! +!----------------------------------------------------------------------- + recursive subroutine mpas_pool_initialize_time_levels(inPool)!{{{ + + implicit none + + type (mpas_pool_type), pointer :: inPool + + integer :: i, j + type (mpas_pool_member_type), pointer :: ptr + type (mpas_pool_data_type), pointer :: dptr + type (mpas_pool_data_type), pointer :: mem + type (mpas_pool_type), pointer :: subPool + type (mpas_pool_iterator_type) :: itr + + call mpas_pool_begin_iteration(inPool) + do while (mpas_pool_get_next_member(inPool, itr)) + if (itr % memberType == MPAS_POOL_SUBPOOL) then + call mpas_pool_get_subpool(inPool, itr % memberName, subPool) + call mpas_pool_initialize_time_levels(subPool) + else if (itr % memberType == MPAS_POOL_FIELD) then + if (itr % nTimeLevels > 1) then + mem => pool_get_member(inPool, itr % memberName, MPAS_POOL_FIELD) + if (itr % dataType == MPAS_POOL_REAL) then + if (itr % nDims == 0) then + do i = 2, itr % nTimeLevels + mem % r0 => mem % r0a(i) + call mpas_duplicate_field(mem % r0a(1), mem % r0, copy_array_only=.true.) + nullify(mem % r0) + end do + else if (itr % nDims == 1) then + do i = 2, itr % nTimeLevels + mem % r1 => mem % r1a(i) + call mpas_duplicate_field(mem % r1a(1), mem % r1, copy_array_only=.true.) + nullify(mem % r1) + end do + else if (itr % nDims == 2) then + do i = 2, itr % nTimeLevels + mem % r2 => mem % r2a(i) + call mpas_duplicate_field(mem % r2a(1), mem % r2, copy_array_only=.true.) + nullify(mem % r2) + end do + else if (itr % nDims == 3) then + do i = 2, itr % nTimeLevels + mem % r3 => mem % r3a(i) + call mpas_duplicate_field(mem % r3a(1), mem % r3, copy_array_only=.true.) + nullify(mem % r3) + end do + else if (itr % nDims == 4) then + do i = 2, itr % nTimeLevels + mem % r4 => mem % r4a(i) + call mpas_duplicate_field(mem % r4a(1), mem % r4, copy_array_only=.true.) + nullify(mem % r4) + end do + else if (itr % nDims == 5) then + do i = 2, itr % nTimeLevels + mem % r5 => mem % r5a(i) + call mpas_duplicate_field(mem % r5a(1), mem % r5, copy_array_only=.true.) + nullify(mem % r5) + end do + end if + else if (itr % dataType == MPAS_POOL_INTEGER) then + if (itr % nDims == 0) then + do i = 2, itr % nTimeLevels + mem % i0 => mem % i0a(i) + call mpas_duplicate_field(mem % i0a(1), mem % i0, copy_array_only=.true.) + nullify(mem % i0) + end do + else if (itr % nDims == 1) then + do i = 2, itr % nTimeLevels + mem % i1 => mem % i1a(i) + call mpas_duplicate_field(mem % i1a(1), mem % i1, copy_array_only=.true.) + nullify(mem % i1) + end do + else if (itr % nDims == 2) then + do i = 2, itr % nTimeLevels + mem % i2 => mem % i2a(i) + call mpas_duplicate_field(mem % i2a(1), mem % i2, copy_array_only=.true.) + nullify(mem % i2) + end do + else if (itr % nDims == 3) then + do i = 2, itr % nTimeLevels + mem % i3 => mem % i3a(i) + call mpas_duplicate_field(mem % i3a(1), mem % i3, copy_array_only=.true.) + nullify(mem % i3) + end do + end if + else if (itr % dataType == MPAS_POOL_CHARACTER) then + if (itr % nDims == 0) then + do i = 2, itr % nTimeLevels + mem % c0 => mem % c0a(i) + call mpas_duplicate_field(mem % c0a(1), mem % c0, copy_array_only=.true.) + nullify(mem % c0) + end do + else if (itr % nDims == 1) then + do i = 2, itr % nTimeLevels + mem % c1 => mem % c1a(i) + call mpas_duplicate_field(mem % c1a(1), mem % c1, copy_array_only=.true.) + nullify(mem % c1) + end do + end if + end if + end if + end if + end do + + end subroutine mpas_pool_initialize_time_levels!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_link_pools +! +!> \brief MPAS Pool link pools routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine links the fields in three pools together. +!> It assumes all three pools contain the same field members. +!> It will also link subpool fields. +! +!----------------------------------------------------------------------- + recursive subroutine mpas_pool_link_pools(inPool, prevPool, nextPool)!{{{ + + implicit none + + type (mpas_pool_type), pointer :: inPool + type (mpas_pool_type), pointer, optional :: prevPool, nextPool + + integer :: i, j + type (mpas_pool_type), pointer :: subPool, prevSubPool, nextSubPool + type (mpas_pool_data_type), pointer :: poolMem, prevPoolMem, nextPoolMem + type (mpas_pool_iterator_type) :: poolItr + + nullify(prevSubPool) + nullify(nextSubPool) + nullify(prevPoolMem) + nullify(nextPoolMem) + + call mpas_pool_begin_iteration(inPool) + do while (mpas_pool_get_next_member(inPool, poolItr)) + ! Link subpools + if (poolItr % memberType == MPAS_POOL_SUBPOOL) then + call mpas_pool_get_subpool(inPool, poolItr % memberName, subPool) + if (present(prevPool)) then + call mpas_pool_get_subpool(prevPool, poolItr % memberName, prevSubPool) + end if + + if (present(nextPool)) then + call mpas_pool_get_subpool(nextPool, poolItr % memberName, nextSubPool) + end if + + if (associated(prevSubPool) .and. associated(nextSubPool)) then + call mpas_pool_link_pools(subPool, prevSubPool, nextSubPool) + else if (associated(prevSubPool)) then + call mpas_pool_link_pools(subPool, prevSubPool) + else if (associated(nextSubPool)) then + call mpas_pool_link_pools(subPool, nextPool=nextSubPool) + else + call mpas_pool_link_pools(subPool) + end if + + ! Link fields + else if (poolItr % memberType == MPAS_POOL_FIELD) then + + poolMem => pool_get_member(inPool, poolItr % memberName, MPAS_POOL_FIELD) + if (present(prevPool)) then + prevPoolMem => pool_get_member(prevPool, poolItr % memberName, MPAS_POOL_FIELD) + end if + + if (present(nextPool)) then + nextPoolMem => pool_get_member(nextPool, poolItr % memberName, MPAS_POOL_FIELD) + end if + + if (poolItr % dataType == MPAS_POOL_REAL) then + if (poolItr % nDims == 0) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % r0a(i) % prev => prevPoolMem % r0a(i) + else + nullify(poolMem % r0a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r0a(i) % next => nextPoolMem % r0a(i) + else + nullify(poolMem % r0a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % r0 % prev => prevPoolMem % r0 + else + nullify(poolMem % r0 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r0 % next => nextPoolMem % r0 + else + nullify(poolMem % r0 % next) + end if + end if + else if (poolItr % nDims == 1) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % r1a(i) % prev => prevPoolMem % r1a(i) + else + nullify(poolMem % r1a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r1a(i) % next => nextPoolMem % r1a(i) + else + nullify(poolMem % r1a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % r1 % prev => prevPoolMem % r1 + else + nullify(poolMem % r1 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r1 % next => nextPoolMem % r1 + else + nullify(poolMem % r1 % next) + end if + end if + else if (poolItr % nDims == 2) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % r2a(i) % prev => prevPoolMem % r2a(i) + else + nullify(poolMem % r2a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r2a(i) % next => nextPoolMem % r2a(i) + else + nullify(poolMem % r2a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % r2 % prev => prevPoolMem % r2 + else + nullify(poolMem % r2 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r2 % next => nextPoolMem % r2 + else + nullify(poolMem % r2 % next) + end if + end if + else if (poolItr % nDims == 3) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % r3a(i) % prev => prevPoolMem % r3a(i) + else + nullify(poolMem % r3a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r3a(i) % next => nextPoolMem % r3a(i) + else + nullify(poolMem % r3a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % r3 % prev => prevPoolMem % r3 + else + nullify(poolMem % r3 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r3 % next => nextPoolMem % r3 + else + nullify(poolMem % r3 % next) + end if + end if + else if (poolItr % nDims == 4) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % r4a(i) % prev => prevPoolMem % r4a(i) + else + nullify(poolMem % r4a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r4a(i) % next => nextPoolMem % r4a(i) + else + nullify(poolMem % r4a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % r4 % prev => prevPoolMem % r4 + else + nullify(poolMem % r4 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r4 % next => nextPoolMem % r4 + else + nullify(poolMem % r4 % next) + end if + end if + else if (poolItr % nDims == 5) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % r5a(i) % prev => prevPoolMem % r5a(i) + else + nullify(poolMem % r5a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r5a(i) % next => nextPoolMem % r5a(i) + else + nullify(poolMem % r5a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % r5 % prev => prevPoolMem % r5 + else + nullify(poolMem % r5 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % r5 % next => nextPoolMem % r5 + else + nullify(poolMem % r5 % next) + end if + end if + end if + else if (poolItr % dataType == MPAS_POOL_INTEGER) then + if (poolItr % nDims == 0) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % i0a(i) % prev => prevPoolMem % i0a(i) + else + nullify(poolMem % i0a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % i0a(i) % next => nextPoolMem % i0a(i) + else + nullify(poolMem % i0a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % i0 % prev => prevPoolMem % i0 + else + nullify(poolMem % i0 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % i0 % next => nextPoolMem % i0 + else + nullify(poolMem % i0 % next) + end if + end if + else if (poolItr % nDims == 1) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % i1a(i) % prev => prevPoolMem % i1a(i) + else + nullify(poolMem % i1a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % i1a(i) % next => nextPoolMem % i1a(i) + else + nullify(poolMem % i1a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % i1 % prev => prevPoolMem % i1 + else + nullify(poolMem % i1 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % i1 % next => nextPoolMem % i1 + else + nullify(poolMem % i1 % next) + end if + end if + else if (poolItr % nDims == 2) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % i2a(i) % prev => prevPoolMem % i2a(i) + else + nullify(poolMem % i2a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % i2a(i) % next => nextPoolMem % i2a(i) + else + nullify(poolMem % i2a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % i2 % prev => prevPoolMem % i2 + else + nullify(poolMem % i2 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % i2 % next => nextPoolMem % i2 + else + nullify(poolMem % i2 % next) + end if + end if + else if (poolItr % nDims == 3) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % i3a(i) % prev => prevPoolMem % i3a(i) + else + nullify(poolMem % i3a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % i3a(i) % next => nextPoolMem % i3a(i) + else + nullify(poolMem % i3a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % i3 % prev => prevPoolMem % i3 + else + nullify(poolMem % i3 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % i3 % next => nextPoolMem % i3 + else + nullify(poolMem % i3 % next) + end if + end if + end if + else if (poolItr % dataType == MPAS_POOL_CHARACTER) then + if (poolItr % nDims == 0) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % c0a(i) % prev => prevPoolMem % c0a(i) + else + nullify(poolMem % c0a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % c0a(i) % next => nextPoolMem % c0a(i) + else + nullify(poolMem % c0a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % c0 % prev => prevPoolMem % c0 + else + nullify(poolMem % c0 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % c0 % next => nextPoolMem % c0 + else + nullify(poolMem % c0 % next) + end if + end if + else if (poolItr % nDims == 1) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + if (associated(prevPoolMem)) then + poolMem % c1a(i) % prev => prevPoolMem % c1a(i) + else + nullify(poolMem % c1a(i) % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % c1a(i) % next => nextPoolMem % c1a(i) + else + nullify(poolMem % c1a(i) % next) + end if + end do + else + if (associated(prevPoolMem)) then + poolMem % c1 % prev => prevPoolMem % c1 + else + nullify(poolMem % c1 % prev) + end if + + if (associated(nextPoolMem)) then + poolMem % c1 % next => nextPoolMem % c1 + else + nullify(poolMem % c1 % next) + end if + end if + end if + end if + end if + end do + + end subroutine mpas_pool_link_pools!}}} + +!----------------------------------------------------------------------- +! routine mpas_pool_link_parinfo +! +!> \brief MPAS Pool link parinfo in fields routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine links the parallel info exchange lists for pool members. +! +!----------------------------------------------------------------------- + recursive subroutine mpas_pool_link_parinfo(block, inPool)!{{{ + + implicit none + + type (block_type), intent(in) :: block + type (mpas_pool_type), pointer :: inPool + + integer :: i, j, decompType + type (mpas_pool_type), pointer :: subPool + type (mpas_pool_data_type), pointer :: poolMem + type (mpas_pool_iterator_type) :: poolItr + character (len=StrKIND), dimension(:), pointer :: dimNames + + call mpas_pool_begin_iteration(inPool) + do while (mpas_pool_get_next_member(inPool, poolItr)) + ! Link subpools + if (poolItr % memberType == MPAS_POOL_SUBPOOL) then + call mpas_pool_get_subpool(inPool, poolItr % memberName, subPool) + call mpas_pool_link_parinfo(block, subPool) + + ! Link fields + else if (poolItr % memberType == MPAS_POOL_FIELD) then + decompType = -1 + + poolMem => pool_get_member(inPool, poolItr % memberName, MPAS_POOL_FIELD) + + if (poolItr % dataType == MPAS_POOL_REAL) then + if (poolItr % nDims == 0) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + nullify(poolMem % r0a(i) % sendList) + nullify(poolMem % r0a(i) % recvList) + nullify(poolMem % r0a(i) % copyList) + end do + else + nullify(poolMem % r0 % sendList) + nullify(poolMem % r0 % recvList) + nullify(poolMem % r0 % copyList) + end if + else if (poolItr % nDims == 1) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % r1a(1) % dimNames(1)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % r1a(i) % sendList => block % parinfo % cellsToSend + poolMem % r1a(i) % recvList => block % parinfo % cellsToRecv + poolMem % r1a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % r1a(i) % sendList => block % parinfo % edgesToSend + poolMem % r1a(i) % recvList => block % parinfo % edgesToRecv + poolMem % r1a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % r1a(i) % sendList => block % parinfo % verticesToSend + poolMem % r1a(i) % recvList => block % parinfo % verticesToRecv + poolMem % r1a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % r1 % dimNames(1)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % r1 % sendList => block % parinfo % cellsToSend + poolMem % r1 % recvList => block % parinfo % cellsToRecv + poolMem % r1 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % r1 % sendList => block % parinfo % edgesToSend + poolMem % r1 % recvList => block % parinfo % edgesToRecv + poolMem % r1 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % r1 % sendList => block % parinfo % verticesToSend + poolMem % r1 % recvList => block % parinfo % verticesToRecv + poolMem % r1 % copyList => block % parinfo % verticesToCopy + end if + end if + else if (poolItr % nDims == 2) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % r2a(1) % dimNames(2)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % r2a(i) % sendList => block % parinfo % cellsToSend + poolMem % r2a(i) % recvList => block % parinfo % cellsToRecv + poolMem % r2a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % r2a(i) % sendList => block % parinfo % edgesToSend + poolMem % r2a(i) % recvList => block % parinfo % edgesToRecv + poolMem % r2a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % r2a(i) % sendList => block % parinfo % verticesToSend + poolMem % r2a(i) % recvList => block % parinfo % verticesToRecv + poolMem % r2a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % r2 % dimNames(2)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % r2 % sendList => block % parinfo % cellsToSend + poolMem % r2 % recvList => block % parinfo % cellsToRecv + poolMem % r2 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % r2 % sendList => block % parinfo % edgesToSend + poolMem % r2 % recvList => block % parinfo % edgesToRecv + poolMem % r2 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % r2 % sendList => block % parinfo % verticesToSend + poolMem % r2 % recvList => block % parinfo % verticesToRecv + poolMem % r2 % copyList => block % parinfo % verticesToCopy + end if + end if + else if (poolItr % nDims == 3) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % r3a(1) % dimNames(3)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % r3a(i) % sendList => block % parinfo % cellsToSend + poolMem % r3a(i) % recvList => block % parinfo % cellsToRecv + poolMem % r3a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % r3a(i) % sendList => block % parinfo % edgesToSend + poolMem % r3a(i) % recvList => block % parinfo % edgesToRecv + poolMem % r3a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % r3a(i) % sendList => block % parinfo % verticesToSend + poolMem % r3a(i) % recvList => block % parinfo % verticesToRecv + poolMem % r3a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % r3 % dimNames(3)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % r3 % sendList => block % parinfo % cellsToSend + poolMem % r3 % recvList => block % parinfo % cellsToRecv + poolMem % r3 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % r3 % sendList => block % parinfo % edgesToSend + poolMem % r3 % recvList => block % parinfo % edgesToRecv + poolMem % r3 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % r3 % sendList => block % parinfo % verticesToSend + poolMem % r3 % recvList => block % parinfo % verticesToRecv + poolMem % r3 % copyList => block % parinfo % verticesToCopy + end if + end if + else if (poolItr % nDims == 4) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % r4 % dimNames(4)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % r4a(i) % sendList => block % parinfo % cellsToSend + poolMem % r4a(i) % recvList => block % parinfo % cellsToRecv + poolMem % r4a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % r4a(i) % sendList => block % parinfo % edgesToSend + poolMem % r4a(i) % recvList => block % parinfo % edgesToRecv + poolMem % r4a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % r4a(i) % sendList => block % parinfo % verticesToSend + poolMem % r4a(i) % recvList => block % parinfo % verticesToRecv + poolMem % r4a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % r4 % dimNames(4)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % r4 % sendList => block % parinfo % cellsToSend + poolMem % r4 % recvList => block % parinfo % cellsToRecv + poolMem % r4 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % r4 % sendList => block % parinfo % edgesToSend + poolMem % r4 % recvList => block % parinfo % edgesToRecv + poolMem % r4 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % r4 % sendList => block % parinfo % verticesToSend + poolMem % r4 % recvList => block % parinfo % verticesToRecv + poolMem % r4 % copyList => block % parinfo % verticesToCopy + end if + end if + else if (poolItr % nDims == 5) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % r5a(1) % dimNames(5)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % r5a(i) % sendList => block % parinfo % cellsToSend + poolMem % r5a(i) % recvList => block % parinfo % cellsToRecv + poolMem % r5a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % r5a(i) % sendList => block % parinfo % edgesToSend + poolMem % r5a(i) % recvList => block % parinfo % edgesToRecv + poolMem % r5a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % r5a(i) % sendList => block % parinfo % verticesToSend + poolMem % r5a(i) % recvList => block % parinfo % verticesToRecv + poolMem % r5a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % r5 % dimNames(5)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % r5 % sendList => block % parinfo % cellsToSend + poolMem % r5 % recvList => block % parinfo % cellsToRecv + poolMem % r5 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % r5 % sendList => block % parinfo % edgesToSend + poolMem % r5 % recvList => block % parinfo % edgesToRecv + poolMem % r5 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % r5 % sendList => block % parinfo % verticesToSend + poolMem % r5 % recvList => block % parinfo % verticesToRecv + poolMem % r5 % copyList => block % parinfo % verticesToCopy + end if + end if + end if + else if (poolItr % dataType == MPAS_POOL_INTEGER) then + if (poolItr % nDims == 0) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + nullify(poolMem % i0a(i) % sendList) + nullify(poolMem % i0a(i) % recvList) + nullify(poolMem % i0a(i) % copyList) + end do + else + nullify(poolMem % i0 % sendList) + nullify(poolMem % i0 % recvList) + nullify(poolMem % i0 % copyList) + end if + else if (poolItr % nDims == 1) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % i1a(1) % dimNames(1)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % i1a(i) % sendList => block % parinfo % cellsToSend + poolMem % i1a(i) % recvList => block % parinfo % cellsToRecv + poolMem % i1a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % i1a(i) % sendList => block % parinfo % edgesToSend + poolMem % i1a(i) % recvList => block % parinfo % edgesToRecv + poolMem % i1a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % i1a(i) % sendList => block % parinfo % verticesToSend + poolMem % i1a(i) % recvList => block % parinfo % verticesToRecv + poolMem % i1a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % i1 % dimNames(1)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % i1 % sendList => block % parinfo % cellsToSend + poolMem % i1 % recvList => block % parinfo % cellsToRecv + poolMem % i1 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % i1 % sendList => block % parinfo % edgesToSend + poolMem % i1 % recvList => block % parinfo % edgesToRecv + poolMem % i1 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % i1 % sendList => block % parinfo % verticesToSend + poolMem % i1 % recvList => block % parinfo % verticesToRecv + poolMem % i1 % copyList => block % parinfo % verticesToCopy + end if + end if + else if (poolItr % nDims == 2) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % i2a(1) % dimNames(2)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % i2a(i) % sendList => block % parinfo % cellsToSend + poolMem % i2a(i) % recvList => block % parinfo % cellsToRecv + poolMem % i2a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % i2a(i) % sendList => block % parinfo % edgesToSend + poolMem % i2a(i) % recvList => block % parinfo % edgesToRecv + poolMem % i2a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % i2a(i) % sendList => block % parinfo % verticesToSend + poolMem % i2a(i) % recvList => block % parinfo % verticesToRecv + poolMem % i2a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % i2 % dimNames(2)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % i2 % sendList => block % parinfo % cellsToSend + poolMem % i2 % recvList => block % parinfo % cellsToRecv + poolMem % i2 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % i2 % sendList => block % parinfo % edgesToSend + poolMem % i2 % recvList => block % parinfo % edgesToRecv + poolMem % i2 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % i2 % sendList => block % parinfo % verticesToSend + poolMem % i2 % recvList => block % parinfo % verticesToRecv + poolMem % i2 % copyList => block % parinfo % verticesToCopy + end if + end if + else if (poolItr % nDims == 3) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % i3a(1) % dimNames(3)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % i3a(i) % sendList => block % parinfo % cellsToSend + poolMem % i3a(i) % recvList => block % parinfo % cellsToRecv + poolMem % i3a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % i3a(i) % sendList => block % parinfo % edgesToSend + poolMem % i3a(i) % recvList => block % parinfo % edgesToRecv + poolMem % i3a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % i3a(i) % sendList => block % parinfo % verticesToSend + poolMem % i3a(i) % recvList => block % parinfo % verticesToRecv + poolMem % i3a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % i3 % dimNames(3)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % i3 % sendList => block % parinfo % cellsToSend + poolMem % i3 % recvList => block % parinfo % cellsToRecv + poolMem % i3 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % i3 % sendList => block % parinfo % edgesToSend + poolMem % i3 % recvList => block % parinfo % edgesToRecv + poolMem % i3 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % i3 % sendList => block % parinfo % verticesToSend + poolMem % i3 % recvList => block % parinfo % verticesToRecv + poolMem % i3 % copyList => block % parinfo % verticesToCopy + end if + end if + end if + else if (poolItr % dataType == MPAS_POOL_CHARACTER) then + if (poolItr % nDims == 0) then + if (poolItr % nTimeLevels > 1) then + do i = 1, poolItr % nTimeLevels + nullify(poolMem % c0a(i) % sendList) + nullify(poolMem % c0a(i) % recvList) + nullify(poolMem % c0a(i) % copyList) + end do + else + nullify(poolMem % c0 % sendList) + nullify(poolMem % c0 % recvList) + nullify(poolMem % c0 % copyList) + end if + else if (poolItr % nDims == 1) then + if (poolItr % nTimeLevels > 1) then + decompType = pool_get_member_decomp_type(poolMem % c1a(1) % dimNames(1)) + + if (decompType == MPAS_DECOMP_CELLS) then + do i = 1, poolItr % nTimeLevels + poolMem % c1a(i) % sendList => block % parinfo % cellsToSend + poolMem % c1a(i) % recvList => block % parinfo % cellsToRecv + poolMem % c1a(i) % copyList => block % parinfo % cellsToCopy + end do + else if (decompType == MPAS_DECOMP_EDGES) then + do i = 1, poolItr % nTimeLevels + poolMem % c1a(i) % sendList => block % parinfo % edgesToSend + poolMem % c1a(i) % recvList => block % parinfo % edgesToRecv + poolMem % c1a(i) % copyList => block % parinfo % edgesToCopy + end do + else if (decompType == MPAS_DECOMP_VERTICES) then + do i = 1, poolItr % nTimeLevels + poolMem % c1a(i) % sendList => block % parinfo % verticesToSend + poolMem % c1a(i) % recvList => block % parinfo % verticesToRecv + poolMem % c1a(i) % copyList => block % parinfo % verticesToCopy + end do + end if + else + decompType = pool_get_member_decomp_type(poolMem % c1 % dimNames(1)) + + if (decompType == MPAS_DECOMP_CELLS) then + poolMem % c1 % sendList => block % parinfo % cellsToSend + poolMem % c1 % recvList => block % parinfo % cellsToRecv + poolMem % c1 % copyList => block % parinfo % cellsToCopy + else if (decompType == MPAS_DECOMP_EDGES) then + poolMem % c1 % sendList => block % parinfo % edgesToSend + poolMem % c1 % recvList => block % parinfo % edgesToRecv + poolMem % c1 % copyList => block % parinfo % edgesToCopy + else if (decompType == MPAS_DECOMP_VERTICES) then + poolMem % c1 % sendList => block % parinfo % verticesToSend + poolMem % c1 % recvList => block % parinfo % verticesToRecv + poolMem % c1 % copyList => block % parinfo % verticesToCopy + end if + end if + end if + end if + end if + end do + + end subroutine mpas_pool_link_parinfo!}}} + + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_0d_real +! +!> \brief MPAS Pool 0D Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 0D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_0d_real(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field0DReal), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 1 + newmem % data % r0 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_0d_real!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_1d_real +! +!> \brief MPAS Pool 1D Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 1D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_1d_real(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field1DReal), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 1 + newmem % data % contentsTimeLevs = 1 + newmem % data % r1 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_1d_real!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_2d_real +! +!> \brief MPAS Pool 2D Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 2D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_2d_real(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field2DReal), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 2 + newmem % data % contentsTimeLevs = 1 + newmem % data % r2 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_2d_real!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_3d_real +! +!> \brief MPAS Pool 3D Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 3D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_3d_real(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field3DReal), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 3 + newmem % data % contentsTimeLevs = 1 + newmem % data % r3 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_3d_real!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_4d_real +! +!> \brief MPAS Pool 4D Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 4D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_4d_real(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field4DReal), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 4 + newmem % data % contentsTimeLevs = 1 + newmem % data % r4 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_4d_real!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_5d_real +! +!> \brief MPAS Pool 5D Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 5D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_5d_real(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field5DReal), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 5 + newmem % data % contentsTimeLevs = 1 + newmem % data % r5 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_5d_real!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_0d_int +! +!> \brief MPAS Pool 0D Integer field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 0D integer field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_0d_int(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field0DInteger), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 1 + newmem % data % i0 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_0d_int!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_1d_int +! +!> \brief MPAS Pool 1D Integer field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 1D integer field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_1d_int(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field1DInteger), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 1 + newmem % data % contentsTimeLevs = 1 + newmem % data % i1 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_1d_int!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_2d_int +! +!> \brief MPAS Pool 2D Integer field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 2D integer field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_2d_int(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field2DInteger), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 2 + newmem % data % contentsTimeLevs = 1 + newmem % data % i2 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_2d_int!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_3d_int +! +!> \brief MPAS Pool 3D Integer field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 3D integer field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_3d_int(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field3DInteger), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 3 + newmem % data % contentsTimeLevs = 1 + newmem % data % i3 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_3d_int!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_0d_char +! +!> \brief MPAS Pool 0D Character field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 0D character field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_0d_char(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field0DChar), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_CHARACTER + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 1 + newmem % data % c0 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_0d_char!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_1d_char +! +!> \brief MPAS Pool 1D Character field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts field into inPool when field is a 1D character field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_1d_char(inPool, key, field)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field1DChar), pointer :: field + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_CHARACTER + newmem % data % contentsDims = 1 + newmem % data % contentsTimeLevs = 1 + newmem % data % c1 => field + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_1d_char!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_0d_reals +! +!> \brief MPAS Pool 0D Multi-level Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 0D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_0d_reals(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field0DReal), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % r0 => fields(1) + else + newmem % data % r0a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_0d_reals!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_1d_reals +! +!> \brief MPAS Pool 1D Multi-level Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 1D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_1d_reals(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field1DReal), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 1 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % r1 => fields(1) + else + newmem % data % r1a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_1d_reals!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_2d_reals +! +!> \brief MPAS Pool 2D Multi-level Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 2D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_2d_reals(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field2DReal), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 2 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % r2 => fields(1) + else + newmem % data % r2a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_2d_reals!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_3d_reals +! +!> \brief MPAS Pool 3D Multi-level Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 3D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_3d_reals(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field3DReal), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 3 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % r3 => fields(1) + else + newmem % data % r3a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_3d_reals!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_4d_reals +! +!> \brief MPAS Pool 4D Multi-level Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 4D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_4d_reals(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field4DReal), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 4 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % r4 => fields(1) + else + newmem % data % r4a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_4d_reals!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_5d_reals +! +!> \brief MPAS Pool 5D Multi-level Real field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 5D real field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_5d_reals(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field5DReal), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 5 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % r5 => fields(1) + else + newmem % data % r5a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_5d_reals!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_0d_ints +! +!> \brief MPAS Pool 0D Multi-level Integer field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 0D integer field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_0d_ints(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field0DInteger), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % i0 => fields(1) + else + newmem % data % i0a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_0d_ints!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_1d_ints +! +!> \brief MPAS Pool 1D Multi-level Integer field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 1D integer field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_1d_ints(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field1DInteger), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % keyLen = len_trim(key) + newmem % key = trim(key) + newmem % contentsType = MPAS_POOL_FIELD + nullify(newmem % next) + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 1 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % i1 => fields(1) + else + newmem % data % i1a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_1d_ints!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_2d_ints +! +!> \brief MPAS Pool 2D Multi-level integer field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 2D integer field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_2d_ints(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field2DInteger), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 2 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % i2 => fields(1) + else + newmem % data % i2a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_2d_ints!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_3d_ints +! +!> \brief MPAS Pool 3D Multi-level Integer field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 3D integer field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_3d_ints(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field3DInteger), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 3 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % i3 => fields(1) + else + newmem % data % i3a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_3d_ints!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_0d_chars +! +!> \brief MPAS Pool 0D Multi-level Character field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 0D character field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_0d_chars(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field0DChar), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_CHARACTER + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % c0 => fields(1) + else + newmem % data % c0a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_0d_chars!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_field_1d_chars +! +!> \brief MPAS Pool 1D Multi-level Character field add routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts fields into inPool when fields is a multi-level 1D character field +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_field_1d_chars(inPool, key, fields)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (field1DChar), dimension(:), pointer :: fields + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_FIELD + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_CHARACTER + newmem % data % contentsDims = 1 + newmem % data % contentsTimeLevs = size(fields) + if (newmem % data % contentsTimeLevs == 1) then + newmem % data % c1 => fields(1) + else + newmem % data % c1a => fields + end if + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_field_1d_chars!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_info +! +!> \brief MPAS Pool Field Information Query subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a data structure containing information related to the +!> field in inPool with the name key +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_info(inPool, key, info)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (mpas_pool_field_info_type), intent(out) :: info + + integer :: hash, endl + type (mpas_pool_member_type), pointer :: ptr + + + endl = len_trim(key) + call pool_hash(hash, key, endl) + + hash = mod(hash, inPool % size) + 1 + + ptr => inPool % table(hash) % head + do while (associated(ptr)) + if (ptr % contentsType == MPAS_POOL_FIELD) then + if (endl == ptr % keyLen) then + if (key(1:endl) == ptr % key(1:endl)) then + + info % fieldType = ptr % data % contentsType + info % nDims = ptr % data % contentsDims + info % nTimeLevels = ptr % data % contentsTimeLevs + + if ( info % fieldType == MPAS_POOL_REAL ) then + if ( info % nDims == 0 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % r0a(1) % isActive + else + info % isActive = ptr % data % r0 % isActive + end if + else if ( info % nDims == 1 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % r1a(1) % isActive + else + info % isActive = ptr % data % r1 % isActive + end if + else if ( info % nDims == 2 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % r2a(1) % isActive + else + info % isActive = ptr % data % r2 % isActive + end if + else if ( info % nDims == 3 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % r3a(1) % isActive + else + info % isActive = ptr % data % r3 % isActive + end if + else if ( info % nDims == 4 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % r4a(1) % isActive + else + info % isActive = ptr % data % r4 % isActive + end if + else if ( info % nDims == 5 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % r5a(1) % isActive + else + info % isActive = ptr % data % r5 % isActive + end if + end if + else if (info % fieldType == MPAS_POOL_INTEGER ) then + if ( info % nDims == 0 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % i0a(1) % isActive + else + info % isActive = ptr % data % i0 % isActive + end if + else if ( info % nDims == 1 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % i1a(1) % isActive + else + info % isActive = ptr % data % i1 % isActive + end if + else if ( info % nDims == 2 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % i2a(1) % isActive + else + info % isActive = ptr % data % i2 % isActive + end if + else if ( info % nDims == 3 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % i3a(1) % isActive + else + info % isActive = ptr % data % i3 % isActive + end if + end if + else if (info % fieldType == MPAS_POOL_CHARACTER ) then + if ( info % nDims == 0 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % c0a(1) % isActive + else + info % isActive = ptr % data % c0 % isActive + end if + else if ( info % nDims == 1 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % c1a(1) % isActive + else + info % isActive = ptr % data % c1 % isActive + end if + end if + else if (info % fieldType == MPAS_POOL_LOGICAL ) then + if ( info % nDims == 0 ) then + if ( info % nTimeLevels > 1 ) then + info % isActive = ptr % data % l0a(1) % isActive + else + info % isActive = ptr % data % l0 % isActive + end if + end if + end if + exit + end if + end if + end if + ptr => ptr % next + end do + + if (.not. associated(ptr)) then + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_field_info!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_0d_real +! +!> \brief MPAS Pool 0D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_0d_real(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field0DReal), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_REAL) then + call pool_mesg('Error: Field '//trim(key)//' is not type real.') + end if + if (mem % contentsDims /= 0) then + call pool_mesg('Error: Field '//trim(key)//' is not a 0-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % r0 + else + field => mem % r0a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_0d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_1d_real +! +!> \brief MPAS Pool 1D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_1d_real(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field1DReal), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_REAL) then + call pool_mesg('Error: Field '//trim(key)//' is not type real.') + end if + if (mem % contentsDims /= 1) then + call pool_mesg('Error: Field '//trim(key)//' is not a 1-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % r1 + else + field => mem % r1a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_1d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_2d_real +! +!> \brief MPAS Pool 2D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_2d_real(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field2DReal), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_REAL) then + call pool_mesg('Error: Field '//trim(key)//' is not type real.') + end if + if (mem % contentsDims /= 2) then + call pool_mesg('Error: Field '//trim(key)//' is not a 2-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % r2 + else + field => mem % r2a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_2d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_3d_real +! +!> \brief MPAS Pool 3D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_3d_real(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field3DReal), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_REAL) then + call pool_mesg('Error: Field '//trim(key)//' is not type real.') + end if + if (mem % contentsDims /= 3) then + call pool_mesg('Error: Field '//trim(key)//' is not a 3-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % r3 + else + field => mem % r3a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_3d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_4d_real +! +!> \brief MPAS Pool 4D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_4d_real(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field4DReal), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_REAL) then + call pool_mesg('Error: Field '//trim(key)//' is not type real.') + end if + if (mem % contentsDims /= 4) then + call pool_mesg('Error: Field '//trim(key)//' is not a 4-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % r4 + else + field => mem % r4a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_4d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_5d_real +! +!> \brief MPAS Pool 5D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_5d_real(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field5DReal), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_REAL) then + call pool_mesg('Error: Field '//trim(key)//' is not type real.') + end if + if (mem % contentsDims /= 5) then + call pool_mesg('Error: Field '//trim(key)//' is not a 5-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % r5 + else + field => mem % r5a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_5d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_0d_int +! +!> \brief MPAS Pool 0D Integer field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_0d_int(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field0DInteger), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_INTEGER) then + call pool_mesg('Error: Field '//trim(key)//' is not type integer.') + end if + if (mem % contentsDims /= 0) then + call pool_mesg('Error: Field '//trim(key)//' is not a 0-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % i0 + else + field => mem % i0a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_0d_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_1d_int +! +!> \brief MPAS Pool 1D Integer field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_1d_int(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field1DInteger), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_INTEGER) then + call pool_mesg('Error: Field '//trim(key)//' is not type integer.') + end if + if (mem % contentsDims /= 1) then + call pool_mesg('Error: Field '//trim(key)//' is not a 1-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % i1 + else + field => mem % i1a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_1d_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_2d_int +! +!> \brief MPAS Pool 2D Integer field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_2d_int(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field2DInteger), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_INTEGER) then + call pool_mesg('Error: Field '//trim(key)//' is not type integer.') + end if + if (mem % contentsDims /= 2) then + call pool_mesg('Error: Field '//trim(key)//' is not a 2-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % i2 + else + field => mem % i2a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_2d_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_3d_int +! +!> \brief MPAS Pool 3D Integer field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_3d_int(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field3DInteger), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_INTEGER) then + call pool_mesg('Error: Field '//trim(key)//' is not type integer.') + end if + if (mem % contentsDims /= 3) then + call pool_mesg('Error: Field '//trim(key)//' is not a 3-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % i3 + else + field => mem % i3a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_3d_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_0d_char +! +!> \brief MPAS Pool 0D Character field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_0d_char(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field0DChar), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_CHARACTER) then + call pool_mesg('Error: Field '//trim(key)//' is not type character.') + end if + if (mem % contentsDims /= 0) then + call pool_mesg('Error: Field '//trim(key)//' is not a 0-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % c0 + else + field => mem % c0a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_0d_char!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_field_1d_char +! +!> \brief MPAS Pool 1D Character field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the field associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_field_1d_char(inPool, key, field, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (field1DChar), pointer :: field + integer, intent(in), optional :: timeLevel + + type (mpas_pool_data_type), pointer :: mem + integer :: local_timeLevel + + + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + + mem => pool_get_member(inPool, key, MPAS_POOL_FIELD) + + nullify(field) + if (associated(mem)) then + + if (mem % contentsType /= MPAS_POOL_CHARACTER) then + call pool_mesg('Error: Field '//trim(key)//' is not type character.') + end if + if (mem % contentsDims /= 1) then + call pool_mesg('Error: Field '//trim(key)//' is not a 1-d field.') + end if + if ((mem % contentsTimeLevs > 1) .and. (.not. present(timeLevel))) then + call pool_mesg('Error: Field '//trim(key)//' has more than one time level, but no timeLevel argument given.') + end if + if (mem % contentsTimeLevs < local_timeLevel) then + call pool_mesg('Error: Field '//trim(key)//' has too few time levels.') + end if + + if (mem % contentsTimeLevs == 1) then + field => mem % c1 + else + field => mem % c1a(local_timeLevel) + end if + + else + + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + + end if + + end subroutine mpas_pool_get_field_1d_char!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_0d_real +! +!> \brief MPAS Pool 0D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_0d_real(inPool, key, scalar, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), pointer :: scalar + integer, intent(in), optional :: timeLevel + + type (field0DReal), pointer :: field + + + call mpas_pool_get_field_0d_real(inPool, key, field, timeLevel) + + nullify(scalar) + if (associated(field)) scalar => field % scalar + + end subroutine mpas_pool_get_array_0d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_1d_real +! +!> \brief MPAS Pool 1D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_1d_real(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DReal), pointer :: field + + + call mpas_pool_get_field_1d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_1d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_2d_real +! +!> \brief MPAS Pool 2D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_2d_real(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field2DReal), pointer :: field + + + call mpas_pool_get_field_2d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_2d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_3d_real +! +!> \brief MPAS Pool 3D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_3d_real(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field3DReal), pointer :: field + + + call mpas_pool_get_field_3d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_3d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_4d_real +! +!> \brief MPAS Pool 4D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_4d_real(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field4DReal), pointer :: field + + + call mpas_pool_get_field_4d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_4d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_5d_real +! +!> \brief MPAS Pool 5D Real field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_5d_real(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field5DReal), pointer :: field + + + call mpas_pool_get_field_5d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_5d_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_0d_int +! +!> \brief MPAS Pool 0D Integer field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_0d_int(inPool, key, scalar, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, pointer :: scalar + integer, intent(in), optional :: timeLevel + + type (field0DInteger), pointer :: field + + + call mpas_pool_get_field_0d_int(inPool, key, field, timeLevel) + + nullify(scalar) + if (associated(field)) scalar => field % scalar + + end subroutine mpas_pool_get_array_0d_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_1d_int +! +!> \brief MPAS Pool 1D Integer field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_1d_int(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DInteger), pointer :: field + + + call mpas_pool_get_field_1d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_1d_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_2d_int +! +!> \brief MPAS Pool 2D Integer field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_2d_int(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field2DInteger), pointer :: field + + + call mpas_pool_get_field_2d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_2d_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_3d_int +! +!> \brief MPAS Pool 3D Integer field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_3d_int(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field3DInteger), pointer :: field + + + call mpas_pool_get_field_3d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_3d_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_0d_char +! +!> \brief MPAS Pool 0D Character field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_0d_char(inPool, key, string, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + character (len=StrKIND), pointer :: string + integer, intent(in), optional :: timeLevel + + type (field0DChar), pointer :: field + + + call mpas_pool_get_field_0d_char(inPool, key, field, timeLevel) + + nullify(string) + if (associated(field)) string => field % scalar + + end subroutine mpas_pool_get_array_0d_char!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_array_1d_char +! +!> \brief MPAS Pool 1D Character field get subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the array associated with key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_array_1d_char(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + character (len=StrKIND), dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DChar), pointer :: field + + + call mpas_pool_get_field_1d_char(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + + end subroutine mpas_pool_get_array_1d_char!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_config_real +! +!> \brief MPAS Pool Real Config Insertion Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts a real value as a config option into inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_config_real(inPool, key, value)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), intent(in) :: value + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_CONFIG + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_REAL + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 0 + allocate(newmem % data % simple_real) + newmem % data % simple_real = value + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_config_real!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_config_int +! +!> \brief MPAS Pool Integer Config Insertion Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts a integer value as a config option into inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_config_int(inPool, key, value)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + integer, intent(in) :: value + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_CONFIG + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 0 + allocate(newmem % data % simple_int) + newmem % data % simple_int = value + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_config_int!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_config_char +! +!> \brief MPAS Pool Character Config Insertion Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts a character string as a config option into inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_config_char(inPool, key, value)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + character (len=*), intent(in) :: value + + type (mpas_pool_member_type), pointer :: newmem + integer :: oldLevel + + oldLevel = currentErrorLevel + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_CONFIG + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_CHARACTER + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 0 + allocate(newmem % data % simple_char) + if (len_trim(value) > StrKIND) then + call mpas_pool_set_error_level(MPAS_POOL_WARN) + call pool_mesg('WARNING mpas_pool_add_config_char: Input value for key '//trim(key)//' longer than StrKIND.') + call mpas_pool_set_error_level(oldLevel) + end if + newmem % data % simple_char = value + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_config_char!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_config_logical +! +!> \brief MPAS Pool Logical Config Insertion Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts a logical flag as a config option into inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_config_logical(inPool, key, value)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + logical, intent(in) :: value + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % keyLen = len_trim(key) + newmem % key = trim(key) + newmem % contentsType = MPAS_POOL_CONFIG + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_LOGICAL + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 0 + allocate(newmem % data % simple_logical) + newmem % data % simple_logical = value + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_config_logical!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_config_type +! +!> \brief Returns the type of a config in an MPAS pool. +!> \author Michael Duda +!> \date 29 October 2014 +!> \details +!> Returns the type of the specified config in the MPAS pool. If the +!> config does not exist in the pool, a value of MPAS_POOL_FATAL is returned. +! +!----------------------------------------------------------------------- + integer function mpas_pool_config_type(inPool, key)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + + type (mpas_pool_data_type), pointer :: mem + + + mem => pool_get_member(inPool, key, MPAS_POOL_CONFIG) + + if (associated(mem)) then + mpas_pool_config_type = mem % contentsType + else + mpas_pool_config_type = MPAS_POOL_FATAL + end if + + end function mpas_pool_config_type!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_config_real +! +!> \brief MPAS Pool Real Config Access Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns the value associated with a config option with the +!> name key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_config_real(inPool, key, value, record)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), pointer :: value + character (len=*), intent(in), optional :: record + type (mpas_pool_type), pointer :: recordPool + + type (mpas_pool_data_type), pointer :: mem + + if ( present(record) ) then + call mpas_pool_get_subpool(inPool, record, recordPool) + mem => pool_get_member(recordPool, key, MPAS_POOL_CONFIG) + else + mem => pool_get_member(inPool, key, MPAS_POOL_CONFIG) + end if + + if (associated(mem)) then + if (mem % contentsType /= MPAS_POOL_REAL) then + call pool_mesg('Error: Config '//trim(key)//' is not type real.') + end if + value => mem % simple_real + else + call pool_mesg('Error: Config '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_config_real!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_config_int +! +!> \brief MPAS Pool Integer Config Access Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns the value associated with a config option with the +!> name key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_config_int(inPool, key, value, record)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, pointer :: value + character (len=*), intent(in), optional :: record + type (mpas_pool_type), pointer :: recordPool + + type (mpas_pool_data_type), pointer :: mem + + if ( present(record) ) then + call mpas_pool_get_subpool(inPool, record, recordPool) + mem => pool_get_member(recordPool, key, MPAS_POOL_CONFIG) + else + mem => pool_get_member(inPool, key, MPAS_POOL_CONFIG) + end if + + if (associated(mem)) then + if (mem % contentsType /= MPAS_POOL_INTEGER) then + call pool_mesg('Error: Config '//trim(key)//' is not type integer.') + end if + value => mem % simple_int + else + call pool_mesg('Error: Config '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_config_int!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_config_char +! +!> \brief MPAS Pool Character Config Access Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns the value associated with a config option with the +!> name key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_config_char(inPool, key, value, record)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + character (len=StrKIND), pointer :: value + character (len=*), intent(in), optional :: record + type (mpas_pool_type), pointer :: recordPool + + type (mpas_pool_data_type), pointer :: mem + + if ( present(record) ) then + call mpas_pool_get_subpool(inPool, record, recordPool) + mem => pool_get_member(recordPool, key, MPAS_POOL_CONFIG) + else + mem => pool_get_member(inPool, key, MPAS_POOL_CONFIG) + end if + + if (associated(mem)) then + if (mem % contentsType /= MPAS_POOL_CHARACTER) then + call pool_mesg('Error: Config '//trim(key)//' is not type character.') + end if + + value => mem % simple_char + else + call pool_mesg('Error: Config '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_config_char!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_config_logical +! +!> \brief MPAS Pool Logical Config Access Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns the value associated with a config option with the +!> name key in inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_config_logical(inPool, key, value, record)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + logical, pointer :: value + character (len=*), intent(in), optional :: record + type (mpas_pool_type), pointer :: recordPool + + type (mpas_pool_data_type), pointer :: mem + + if ( present(record) ) then + call mpas_pool_get_subpool(inPool, record, recordPool) + mem => pool_get_member(recordPool, key, MPAS_POOL_CONFIG) + else + mem => pool_get_member(inPool, key, MPAS_POOL_CONFIG) + end if + + if (associated(mem)) then + if (mem % contentsType /= MPAS_POOL_LOGICAL) then + call pool_mesg('Error: Config '//trim(key)//' is not type logical.') + end if + value => mem % simple_logical + else + call pool_mesg('Error: Config '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_config_logical!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_dimension_0d +! +!> \brief MPAS Pool 0D Dimension Insertion routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts a 0D dimension into inPool, and associated it with key. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_dimension_0d(inPool, key, dim)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + integer, intent(in) :: dim + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_DIMENSION + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 0 + allocate(newmem % data % simple_int) + newmem % data % simple_int = dim + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_dimension_0d!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_dimension_1d +! +!> \brief MPAS Pool 1D Dimension Insertion routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts a 1D dimension into inPool, and associated it with key. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_dimension_1d(inPool, key, dims)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:), intent(in) :: dims + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_DIMENSION + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_INTEGER + newmem % data % contentsDims = size(dims) + newmem % data % contentsTimeLevs = 0 + allocate(newmem % data % simple_int_arr(newmem % data % contentsDims)) + newmem % data % simple_int_arr(:) = dims(:) + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data % simple_int_arr) + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_dimension_1d!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_dimension_0d +! +!> \brief MPAS Pool 0D Dimension Access subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns the value of the 0D dimension associated with key in +!> inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_dimension_0d(inPool, key, dim)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, pointer :: dim + + type (mpas_pool_data_type), pointer :: mem + + + mem => pool_get_member(inPool, key, MPAS_POOL_DIMENSION) + + if (associated(mem)) then + if (mem % contentsDims /= 0) then + call pool_mesg('Error: Dimension '//trim(key)//' is not a scalar.') + else + dim => mem % simple_int + end if + else + call pool_mesg('Error: Dimension '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_dimension_0d!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_dimension_1d +! +!> \brief MPAS Pool 1D Dimension Access subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns the value of the 1D dimension associated with key in +!> inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_dimension_1d(inPool, key, dims)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, pointer, dimension(:) :: dims + + type (mpas_pool_data_type), pointer :: mem + + + mem => pool_get_member(inPool, key, MPAS_POOL_DIMENSION) + + if (associated(mem)) then + if (mem % contentsDims /= 1) then + call pool_mesg('Error: Dimension '//trim(key)//' is not an array.') + else + dims => mem % simple_int_arr + end if + else + call pool_mesg('Error: Dimension '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_dimension_1d!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_add_subpool +! +!> \brief MPAS Pool Subpool insertion routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine inserts a subpool (subPool) into inPool and associated it with +!> the name key. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_subpool(inPool, key, subPool)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (mpas_pool_type), intent(in), target :: subPool + + + type (mpas_pool_member_type), pointer :: newmem + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_SUBPOOL + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_SUBPOOL + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 0 + newmem % data % p => subPool + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_subpool!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_subpool +! +!> \brief MPAS Pool Subpool access subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine returns a pointer to the subpool named key within inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_subpool(inPool, key, subPool)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + type (mpas_pool_type), pointer :: subPool + + type (mpas_pool_data_type), pointer :: mem + + + mem => pool_get_member(inPool, key, MPAS_POOL_SUBPOOL) + + if (associated(mem)) then + subPool => mem % p + else + call pool_mesg('Error: Sub-pool '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_subpool!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_add_package +! +!> \brief MPAS Pool Package insertion subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine inserts a package into a inPool and associates it with the +!> name key. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_add_package(inPool, key, value)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + logical, intent(in) :: value + + type (mpas_pool_member_type), pointer :: newmem + + + allocate(newmem) + newmem % key = trim(key) + newmem % keyLen = len_trim(key) + newmem % contentsType = MPAS_POOL_PACKAGE + + allocate(newmem % data) + newmem % data % contentsType = MPAS_POOL_LOGICAL + newmem % data % contentsDims = 0 + newmem % data % contentsTimeLevs = 0 + allocate(newmem % data % simple_logical) + newmem % data % simple_logical = value + + if (.not. pool_add_member(inPool, key, newmem)) then + deallocate(newmem % data) + deallocate(newmem) + end if + + end subroutine mpas_pool_add_package!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_package +! +!> \brief MPAS Pool Package access subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This subroutine sets the package pointer to point to the logical associated +!> with the package in inPool with name key. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_get_package(inPool, key, package)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + logical, pointer :: package + + type (mpas_pool_data_type), pointer :: mem + + + mem => pool_get_member(inPool, key, MPAS_POOL_PACKAGE) + + if (associated(mem)) then + package => mem % simple_logical + else + call pool_mesg('Error: Package '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_get_package!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_remove_field +! +!> \brief MPAS Pool Field Removal Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine removes a field with the name key from inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_remove_field(inPool, key)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + + + if (.not. pool_remove_member(inPool, key, MPAS_POOL_FIELD)) then + call pool_mesg('Error: Field '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_remove_field!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_remove_config +! +!> \brief MPAS Pool Config Removal Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine removes a config with the name key from inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_remove_config(inPool, key)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + + type (mpas_pool_data_type), pointer :: mem + + !todo: if configs are pointers when being added, don't deallocate when removing. + mem => pool_get_member(inPool, key, MPAS_POOL_CONFIG) + + if (.not. associated(mem)) then + call pool_mesg('Error: Config '//trim(key)//' not found in pool.') + return + end if + + if (mem % contentsType == MPAS_POOL_REAL) then + deallocate(mem % simple_real) + else if (mem % contentsType == MPAS_POOL_INTEGER) then + deallocate(mem % simple_int) + else if (mem % contentsType == MPAS_POOL_CHARACTER) then + deallocate(mem % simple_char) + else if (mem % contentsType == MPAS_POOL_LOGICAL) then + deallocate(mem % simple_logical) + end if + + if (.not. pool_remove_member(inPool, key, MPAS_POOL_CONFIG)) then + call pool_mesg('Error: Config '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_remove_config!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_remove_dimension +! +!> \brief MPAS Pool Dimension Removal Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine removes a dimension with the name key from inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_remove_dimension(inPool, key)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + + type (mpas_pool_data_type), pointer :: mem + + !todo: if dimensions are pointers when being added, don't deallocate when removing. + mem => pool_get_member(inPool, key, MPAS_POOL_DIMENSION) + + if (.not. associated(mem)) then + call pool_mesg('Error: Dimension '//trim(key)//' not found in pool.') + return + end if + + if (mem % contentsDims == 0) then + deallocate(mem % simple_int) + else if (mem % contentsDims == 1) then + deallocate(mem % simple_int_arr) + end if + + if (.not. pool_remove_member(inPool, key, MPAS_POOL_DIMENSION)) then + call pool_mesg('Error: Dimension '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_remove_dimension!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_remove_subpool +! +!> \brief MPAS Pool Subpool Removal Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine removes a subpool with the name key from inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_remove_subpool(inPool, key)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + + + if (.not. pool_remove_member(inPool, key, MPAS_POOL_SUBPOOL)) then + call pool_mesg('Error: Sub-pool '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_remove_subpool!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_remove_package +! +!> \brief MPAS Pool Package Removal Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine removes a package with the name key from inPool. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_remove_package(inPool, key)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + + + if (.not. pool_remove_member(inPool, key, MPAS_POOL_PACKAGE)) then + call pool_mesg('Error: Package '//trim(key)//' not found in pool.') + end if + + end subroutine mpas_pool_remove_package!}}} + + +!----------------------------------------------------------------------- +! routine mpas_pool_begin_iteration +! +!> \brief MPAS Pool Begin Iteration Routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine sets up the pool's internal iterator to iterate over fields. +! +!----------------------------------------------------------------------- + subroutine mpas_pool_begin_iteration(inPool)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + + integer :: i + + + do i=1,inPool % size + if (associated(inPool % table(i) % head)) exit + end do + inPool % iteratorIndex = i + if (i <= inPool % size) then + inPool % iterator => inPool % table(i) % head + else + nullify(inPool % iterator) + end if + + end subroutine mpas_pool_begin_iteration!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_get_next_member +! +!> \brief MPAS Pool Iterate To Next Member subroutine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This function advances the internal iterator to the next member in the pool, +!> and returns an iterator type for the current member, if one exists. The function +!> returns .true. if a valid member was returned, and .false. if there are no members +!> left to be iterated over. +! +!----------------------------------------------------------------------- + logical function mpas_pool_get_next_member(inPool, iterator)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + type (mpas_pool_iterator_type), intent(inout) :: iterator + + integer :: i + + ! + ! As long as there are members left to be iterated over, the inPool%iterator + ! should always be pointing to the next member to be returned + ! + if (associated(inPool % iterator)) then + iterator % memberName = inPool % iterator % key + iterator % memberType = inPool % iterator % contentsType + iterator % dataType = inPool % iterator % data % contentsType + if (iterator % memberType == MPAS_POOL_FIELD) then + iterator % nDims = inPool % iterator % data % contentsDims + iterator % nTimeLevels = inPool % iterator % data % contentsTimeLevs + else if (iterator % memberType == MPAS_POOL_DIMENSION) then + iterator % nDims = inPool % iterator % data % contentsDims + else + iterator % nDims = 0 + iterator % nTimeLevels = 0 + end if + mpas_pool_get_next_member = .true. + + ! Advance iterator to next item + inPool % iterator => inPool % iterator % next + + ! We may have reached the end of list for current head pointer + if (.not. associated(inPool % iterator)) then + do i=inPool % iteratorIndex+1, inPool % size + if (associated(inPool % table(i) % head)) exit + end do + inPool % iteratorIndex = i + if (i <= inPool % size) then + inPool % iterator => inPool % table(i) % head + else + nullify(inPool % iterator) + end if + end if + + else + mpas_pool_get_next_member = .false. + end if + + end function mpas_pool_get_next_member!}}} + + +!----------------------------------------------------------------------- +! subroutine mpas_pool_shift_time_levels +! +!> \brief MPAS Pool Time level shift routine +!> \author Michael Duda, Doug Jacobsen +!> \date 03/27/2014 +!> \details +!> This routine shifts the time levels of all multi-level fields contained within. +!> When shifting, time level 1 becomes time level n, and time level i becomes time level i-1. +! +!----------------------------------------------------------------------- + recursive subroutine mpas_pool_shift_time_levels(inPool)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + + + integer :: i, j + type (mpas_pool_member_type), pointer :: ptr + type (mpas_pool_data_type), pointer :: dptr + + + do i=1,inPool % size + + ptr => inPool % table(i) % head + do while(associated(ptr)) + + if (ptr % contentsType == MPAS_POOL_FIELD) then + + dptr => ptr % data + + if (associated(dptr % r0a)) then + call mpas_shift_time_levs(dptr % r0a) + else if (associated(dptr % r1a)) then + call mpas_shift_time_levs(dptr % r1a) + else if (associated(dptr % r2a)) then + call mpas_shift_time_levs(dptr % r2a) + else if (associated(dptr % r3a)) then + call mpas_shift_time_levs(dptr % r3a) + else if (associated(dptr % r4a)) then + call mpas_shift_time_levs(dptr % r4a) + else if (associated(dptr % r5a)) then + call mpas_shift_time_levs(dptr % r5a) + else if (associated(dptr % i0a)) then + call mpas_shift_time_levs(dptr % i0a) + else if (associated(dptr % i1a)) then + call mpas_shift_time_levs(dptr % i1a) + else if (associated(dptr % i2a)) then + call mpas_shift_time_levs(dptr % i2a) + else if (associated(dptr % i3a)) then + call mpas_shift_time_levs(dptr % i3a) + else if (associated(dptr % c0a)) then + call mpas_shift_time_levs(dptr % c0a) + else if (associated(dptr % c1a)) then + call mpas_shift_time_levs(dptr % c1a) + else if (associated(dptr % l0a)) then + call mpas_shift_time_levs(dptr % l0a) + end if + + else if (ptr % contentsType == MPAS_POOL_SUBPOOL) then + + call mpas_pool_shift_time_levels(ptr % data % p) + + end if + + ptr => ptr % next + end do + + end do + + end subroutine mpas_pool_shift_time_levels!}}} + + +!!!!!!!!!! Private subroutines !!!!!!!!!! + + logical function pool_add_member(inPool, key, newmem) + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + type (mpas_pool_member_type), pointer :: newmem + + integer :: hash, oldLevel + type (mpas_pool_member_type), pointer :: ptr + + call pool_hash(hash, trim(newmem % key), newmem % keylen) + + hash = mod(hash, inPool % size) + 1 + + pool_add_member = .true. + + if (.not. associated(inPool % table(hash) % head)) then + inPool % table(hash) % head => newmem + else + ptr => inPool % table(hash) % head + do while (associated(ptr % next)) + + if (ptr % contentsType == newmem % contentsType .and. & + ptr % keyLen == newmem % keyLen) then + if (ptr % key(1:ptr%keyLen) == newmem % key(1:newmem%keyLen)) then + pool_add_member = .false. + call mpas_pool_set_error_level(MPAS_POOL_FATAL) + call pool_mesg('Error: Field '//trim(key)//' already exists in pool.') + return + end if + end if + + ptr => ptr % next + end do + ptr % next => newmem + end if + + end function pool_add_member + + + function pool_get_member(inPool, key, memType) + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, intent(in) :: memType + + type (mpas_pool_data_type), pointer :: pool_get_member + + integer :: hash, endl + type (mpas_pool_member_type), pointer :: ptr + + + nullify(pool_get_member) + + endl = len_trim(key) + call pool_hash(hash, key, endl) + + hash = mod(hash, inPool % size) + 1 + + ptr => inPool % table(hash) % head + do while (associated(ptr)) + if (ptr % contentsType == memType) then + if (endl == ptr % keyLen) then + if (key(1:endl) == ptr % key(1:endl)) then + pool_get_member => ptr % data + exit + end if + end if + end if + ptr => ptr % next + end do + + end function pool_get_member + + + logical function pool_remove_member(inPool, key, memType)!{{{ + + implicit none + + type (mpas_pool_type), intent(inout) :: inPool + character (len=*), intent(in) :: key + integer, intent(in) :: memType + + integer :: hash, endl + type (mpas_pool_member_type), pointer :: ptr, ptr_prev + + + endl = len_trim(key) + call pool_hash(hash, key, endl) + + hash = mod(hash, inPool % size) + 1 + + if (associated(inPool % table(hash) % head)) then + + ! Is the member at the head of the list? + ptr_prev => inPool % table(hash) % head + if (ptr_prev % contentsType == memType) then + if (endl == ptr_prev % keyLen) then + if (key(1:endl) == ptr_prev % key(1:endl)) then + inPool % table(hash) % head => ptr_prev % next +!TODO: are there cases where we need to delete more data here? + deallocate(ptr_prev) + pool_remove_member = .true. + return + end if + end if + end if + + ! Possibly later in the list? + ptr => ptr_prev % next + do while (associated(ptr)) + if (ptr % contentsType == memType) then + if (endl == ptr % keyLen) then + if (key(1:endl) == ptr % key(1:endl)) then + ptr_prev % next => ptr % next +!TODO: are there cases where we need to delete more data here? + deallocate(ptr) + pool_remove_member = .true. + return + end if + end if + end if + ptr => ptr % next + ptr_prev => ptr_prev % next + end do + + end if + + pool_remove_member = .false. + + end function pool_remove_member!}}} + + + subroutine pool_mesg(mesg) + + implicit none + + character (len=*), intent(in) :: mesg + + if (currentErrorLevel == MPAS_POOL_WARN) then + write(stderrUnit,*) trim(mesg) + else if (currentErrorLevel == MPAS_POOL_FATAL) then + write(stderrUnit,*) trim(mesg) + call mpas_dmpar_global_abort(trim(mesg)) + end if + + end subroutine pool_mesg + + + subroutine pool_print_table_size(pool) + + implicit none + + type (mpas_pool_type), intent(in) :: pool + + integer :: i, head_size, total_size + type (mpas_pool_member_type), pointer :: ptr + + + total_size = 0 + do i=1,pool % size + head_size = 0 + ptr => pool % table(i) % head + do while (associated(ptr)) + head_size = head_size + 1 + ptr => ptr % next + end do + write(stderrUnit,*) 'List ', i, ' : ', head_size + total_size = total_size + head_size + end do + write(stderrUnit,*) '----------------' + write(stderrUnit,*) 'Total: ', total_size + + end subroutine pool_print_table_size + + recursive subroutine pool_print_members(pool) + + implicit none + + type (mpas_pool_type), intent(inout) :: pool + + integer :: i + type (mpas_pool_type), pointer :: subpool + type (mpas_pool_member_type), pointer :: ptr + type (mpas_pool_iterator_type) :: poolItr + + real (kind=RKIND), pointer :: realPtr + integer, pointer :: intPtr + logical, pointer :: logPtr + character (len=StrKIND) :: charPtr + + write(stderrUnit, *) ' Constants: ' + write(stderrUnit, *) ' Real: ', MPAS_POOL_REAL + write(stderrUnit, *) ' Integer: ', MPAS_POOL_INTEGER + write(stderrUnit, *) ' Logical: ', MPAS_POOL_LOGICAL + write(stderrUnit, *) ' Character: ', MPAS_POOL_CHARACTER + +! write(stderrUnit, *) 'Pool Size:' +! call pool_print_table_size(pool) + + call mpas_pool_begin_iteration(pool) + do while(mpas_pool_get_next_member(pool, poolItr)) + + if (poolItr % memberType == MPAS_POOL_SUBPOOL) then + write(stderrUnit, *) '** Found subpool named: ', trim(poolItr % memberName) + call mpas_pool_get_subpool(pool, trim(poolItr % memberName), subpool) + call pool_print_members(subpool) + else if (poolItr % memberType == MPAS_POOL_CONFIG) then + write(stderrUnit, *) ' Config Option: ', trim(poolItr % memberName), poolItr % dataType + else if (poolItr % memberType == MPAS_POOL_DIMENSION) then + write(stderrUnit, *) ' Dimension: ', trim(poolItr % memberName), poolItr % dataType, poolItr % nDims + else if (poolItr % memberType == MPAS_POOL_PACKAGE) then + write(stderrUnit, *) ' Package: ', trim(poolItr % memberName) + else if (poolItr % memberType == MPAS_POOL_FIELD) then + write(stderrUnit, *) ' Field: ', trim(poolItr % memberName), poolItr % dataType, poolItr % nDims, poolItr % nTimeLevels + end if + end do + write(stderrUnit, *) 'Done with pool' + write(stderrUnit, *) '' + + end subroutine pool_print_members + + integer function pool_get_member_decomp_type(dimName) result(decompType) + character (len=*) :: dimName + + + decompType = MPAS_DECOMP_NONDECOMP + + if (trim(dimName) == 'nCells') then + decompType = MPAS_DECOMP_CELLS + else if (trim(dimName) == 'nEdges') then + decompType = MPAS_DECOMP_EDGES + else if (trim(dimName) == 'nVertices') then + decompType = MPAS_DECOMP_VERTICES + end if + + end function pool_get_member_decomp_type + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! END POOL SUBROUTINES +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/framework/random_id.c b/src/framework/random_id.c new file mode 100644 index 0000000000..567bc51887 --- /dev/null +++ b/src/framework/random_id.c @@ -0,0 +1,38 @@ +// Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +// and the University Corporation for Atmospheric Research (UCAR). +// +// Unless noted otherwise source code is licensed under the BSD license. +// Additional copyright and license information can be found in the LICENSE file +// distributed with this code, or at http://mpas-dev.github.com/license.html +// + +#include +#include + +#ifdef UNDERSCORE +#define gen_random gen_random_ +#define seed_random seed_random_ +#else +#ifdef DOUBLEUNDERSCORE +#define gen_random gen_random__ +#define seed_random seed_random__ +#endif +#endif + +void seed_random() { + srand(time(NULL)); +} + +void gen_random(int * len, char * id) {/*{{{*/ + int i; + int r; + static const char alphanum[] = + "0123456789" + "abcdefghijklmnopqrstuvwxyz"; + + for (i = 0; i < *len; ++i) { + r = rand(); + id[i] = alphanum[r % (sizeof(alphanum) - 1)]; + } + +}/*}}}*/ diff --git a/src/framework/shift_time_levs_array.inc b/src/framework/shift_time_levs_array.inc new file mode 100644 index 0000000000..59f00dbdd8 --- /dev/null +++ b/src/framework/shift_time_levs_array.inc @@ -0,0 +1,40 @@ + !!!!!!!!!!!!!!!!!!!!!!! + ! Implementation note: + ! + ! In this subroutine, we use an array of fields as a ready-made array + ! of field pointers; these pointers exist in the field types as 'next' pointers + !!!!!!!!!!!!!!!!!!!!!!! + + + nlevs = size(fldarr) + allocate(fldarr_ptr(nlevs)) + + ! + ! Initialize pointers to first block of all time levels + ! + do i=1,nlevs + fldarr_ptr(i) % next => fldarr(i) + end do + + + ! + ! Loop over all blocks + ! + do while (associated(fldarr_ptr(1) % next)) + + ! + ! Shift time levels for this block + ! + arr_ptr => fldarr_ptr(1) % next % array + do i=1,nlevs-1 + fldarr_ptr(i) % next % array => fldarr_ptr(i+1) % next % array + end do + fldarr_ptr(nlevs) % next % array => arr_ptr + + ! Advance pointers to next block + do i=1,nlevs + fldarr_ptr(i) % next => fldarr_ptr(i) % next % next + end do + end do + + deallocate(fldarr_ptr) diff --git a/src/framework/shift_time_levs_scalar.inc b/src/framework/shift_time_levs_scalar.inc new file mode 100644 index 0000000000..f5a0bffc98 --- /dev/null +++ b/src/framework/shift_time_levs_scalar.inc @@ -0,0 +1,40 @@ + !!!!!!!!!!!!!!!!!!!!!!! + ! Implementation note: + ! + ! In this subroutine, we use an array of fields as a ready-made array + ! of field pointers; these pointers exist in the field types as 'next' pointers + !!!!!!!!!!!!!!!!!!!!!!! + + + nlevs = size(fldarr) + allocate(fldarr_ptr(nlevs)) + + ! + ! Initialize pointers to first block of all time levels + ! + do i=1,nlevs + fldarr_ptr(i) % next => fldarr(i) + end do + + + ! + ! Loop over all blocks + ! + do while (associated(fldarr_ptr(1) % next)) + + ! + ! Shift time levels for this block + ! + scalar = fldarr_ptr(1) % next % scalar + do i=1,nlevs-1 + fldarr_ptr(i) % next % scalar = fldarr_ptr(i+1) % next % scalar + end do + fldarr_ptr(nlevs) % next % scalar = scalar + + ! Advance pointers to next block + do i=1,nlevs + fldarr_ptr(i) % next => fldarr_ptr(i) % next % next + end do + end do + + deallocate(fldarr_ptr) diff --git a/src/framework/xml_stream_parser.c b/src/framework/xml_stream_parser.c new file mode 100644 index 0000000000..ba5d51d03c --- /dev/null +++ b/src/framework/xml_stream_parser.c @@ -0,0 +1,1523 @@ +// Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +// and the University Corporation for Atmospheric Research (UCAR). +// +// Unless noted otherwise source code is licensed under the BSD license. +// Additional copyright and license information can be found in the LICENSE file +// distributed with this code, or at http://mpas-dev.github.com/license.html +// + +#include +#include +#include +#include +#include +#include +#include +#include "ezxml/ezxml.h" + +#ifdef _MPI +#include "mpi.h" +#endif + +#define MSGSIZE 256 + + +/* + * Interface routines for building streams at run-time; defined in mpas_stream_manager.F + */ +void stream_mgr_create_stream_c(void *, const char *, int *, const char *, const char *, char *, char *, int *, int *, int *, int *); +void mpas_stream_mgr_add_field_c(void *, const char *, const char *, int *); +void mpas_stream_mgr_add_stream_fields_c(void *, const char *, const char *, int *); +void mpas_stream_mgr_add_pool_c(void *, const char *, const char *, int *); +void stream_mgr_add_alarm_c(void *, const char *, const char *, const char *, const char *, int *); +void stream_mgr_add_pkg_c(void *, const char *, const char *, int *); + + +/* + * Stack node type used for basic syntax checking of XML + */ +struct stacknode { + int line; + char name[MSGSIZE]; + struct stacknode *next; +}; + +struct stacknode *head = NULL; + + +/* + * Global variables + */ +static char *global_file; + + +/********************************************************************************* + * + * Function: fmt_err + * + * Prints an error message in a standard format. + * + *********************************************************************************/ +void fmt_err(const char *mesg) +{ + fprintf(stderr,"********************************************************************************\n"); + fprintf(stderr,"* Error: In file %s, %s\n", global_file, mesg); + fprintf(stderr,"********************************************************************************\n"); +} + + +/********************************************************************************* + * + * Function: fmt_warn + * + * Prints a warning message in a standard format. + * + *********************************************************************************/ +void fmt_warn(const char *mesg) +{ + fprintf(stderr,"********************************************************************************\n"); + fprintf(stderr,"* Warning: In file %s, %s\n", global_file, mesg); + fprintf(stderr,"********************************************************************************\n"); +} + +/********************************************************************************* + * + * Function: fmt_info + * + * Prints an informational message in a standard format. + * + *********************************************************************************/ +void fmt_info(const char *mesg) +{ + fprintf(stderr,"\n"); + fprintf(stderr," Information: In file %s, %s\n", global_file, mesg); + fprintf(stderr,"\n"); +} + + +/********************************************************************************* + * + * Function: push_tag + * + * Pushes a new node onto the stack. + * + *********************************************************************************/ +void push_tag(struct stacknode *node) +{ + if (node != NULL) { + node->next = head; + head = node; + } +} + + +/********************************************************************************* + * + * Function: pop_tag + * + * Pops a new node from the stack. + * + *********************************************************************************/ +struct stacknode * pop_tag(void) +{ + struct stacknode *retval; + + retval = head; + if (head != NULL) { + head = head->next; + } + + return retval; +} + + +/********************************************************************************* + * + * Function: parse_xml_tag_name + * + * Copies only the name of an XML tag from tag_buf into tag_name. For example, + * the name of the tag + * + * + * + * is the string "stream". + * + *********************************************************************************/ +void parse_xml_tag_name(char *tag_buf, char *tag_name) +{ + size_t i; + + /* Assume that a name ends with a space or null character */ + i = 0; + while (tag_buf[i] != ' ' && tag_buf[i] != '\0') { + tag_name[i] = tag_buf[i]; + i++; + } + + tag_name[i] = '\0'; +} + + +/********************************************************************************* + * + * Function: parse_xml_tag + * + * Parses the next XML tag into a string, plus other bookkeeping. All characters + * between the first '<' and immediately following '>' character from xml_buf + * are copied into tag. The length of the buffer xml_buf is at least buf_len, and + * the length of the buffer tag is also at least buf_len. + * + * For providing useful error messages, this routine also counts line numbers, + * incrementing the line number each time a newline character is encountered. + * + * The output argument start_line provides the line number on which the returned + * tag began. + * + * The output argument tag_len provides the number of characters in the tag that + * were copied into the tag buffer. If no complete XML tag is found in the input + * buffer, the tag_len argument will be set to 0. + * + * The return value is the index in xml_buf representing the end of the tag, + * realtive to the starting position. + * + *********************************************************************************/ +size_t parse_xml_tag(char *xml_buf, size_t buf_len, char *tag, size_t *tag_len, int *line, int *start_line) +{ + size_t i, j; + + /* Look for beginning of tag */ + i = 0; + while (i < buf_len && xml_buf[i] != '<') { + if (xml_buf[i] == '\n') + (*line)++; + i++; + } + + /* Ran out of characters... */ + if (i == buf_len) { + *tag_len = 0; + return 0; + } + + + /* Move on to next character after opening '<' */ + *start_line = *line; + i++; + + /* Copy tag into string */ + j = 0; + while (i < buf_len && xml_buf[i] != '>') { + if (xml_buf[i] == '\n') + (*line)++; + tag[j] = xml_buf[i]; + i++; + j++; + } + + /* Didn't find a closing '>' character */ + if (i == buf_len) { + *tag_len = 0; + return 0; + } + + tag[j] = '\0'; + i++; + + *tag_len = j; + + return i; +} + + +/********************************************************************************* + * + * Function: par_read + * + * Reads the contents of a file into a buffer in distributed-memory parallel code. + * + * The buffer xml_buf is allocated with size bufsize, which will be exactly the + * number of bytes in the file fname. Only the master task will actually read the + * file, and the contents are broadcast to all other tasks. The mpi_comm argument + * is a Fortran MPI communicator used to determine which task is the master task. + * + * A return code of 0 indicates the file was successfully read and broadcast to + * all MPI tasks that belong to the communicator. + * + *********************************************************************************/ +int par_read(char *fname, int *mpi_comm, char **xml_buf, size_t *bufsize) +{ + int iofd; + int rank; + struct stat s; + int err; + +#ifdef _MPI + MPI_Comm comm; + + comm = MPI_Comm_f2c((MPI_Fint)(*mpi_comm)); + err = MPI_Comm_rank(comm, &rank); +#else + rank = 0; +#endif + + if (rank == 0) { + iofd = open(fname, O_RDONLY); + if (!iofd) { + fprintf(stderr, "********************************************************************************\n\n"); + fprintf(stderr, "Error: Could not open run-time I/O config file %s\n\n", fname); + fprintf(stderr, "********************************************************************************\n"); + return 1; + } + + fstat(iofd, &s); + *bufsize = (size_t)s.st_size; +#ifdef _MPI + err = MPI_Bcast((void *)bufsize, (int)sizeof(size_t), MPI_BYTE, 0, comm); +#endif + + *xml_buf = (char *)malloc(*bufsize); + err = read(iofd, (void *)(*xml_buf), *bufsize); + +#ifdef _MPI + err = MPI_Bcast((void *)(*xml_buf), (int)(*bufsize), MPI_CHAR, 0, comm); +#endif + } + else { +#ifdef _MPI + err = MPI_Bcast((void *)bufsize, (int)sizeof(size_t), MPI_BYTE, 0, comm); +#endif + *xml_buf = (char *)malloc(*bufsize); + +#ifdef _MPI + err = MPI_Bcast((void *)(*xml_buf), (int)(*bufsize), MPI_CHAR, 0, comm); +#endif + } + + return 0; +} + + +/********************************************************************************* + * + * Function: attribute_check + * + * Checks that a stream has the required attributes, and that attributes + * are consistent. + * + *********************************************************************************/ +int attribute_check(ezxml_t stream) +{ + const char *s_name, *s_type, *s_filename, *s_filename_intv, *s_input, *s_output, *s_ref_time; + char msgbuf[MSGSIZE]; + int i, len, nextchar; + + s_name = ezxml_attr(stream, "name"); + s_type = ezxml_attr(stream, "type"); + s_filename = ezxml_attr(stream, "filename_template"); + s_filename_intv = ezxml_attr(stream, "filename_interval"); + s_input = ezxml_attr(stream, "input_interval"); + s_output = ezxml_attr(stream, "output_interval"); + s_ref_time = ezxml_attr(stream, "reference_time"); + + + /* + * Check for required attributes + */ + if (s_name == NULL) { + fmt_err("stream must have the \"name\" attribute."); + return 1; + } + else if (s_type == NULL) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" must have the \"type\" attribute.", s_name); + fmt_err(msgbuf); + return 1; + } + else if (s_filename == NULL) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" must have the \"filename_template\" attribute.", s_name); + fmt_err(msgbuf); + return 1; + } + + + /* + * Check that input streams have an input interval, output streams have an output interval + */ + if (strstr(s_type, "input") != NULL && s_input == NULL) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" is an input stream and must have the \"input_interval\" attribute.", s_name); + fmt_err(msgbuf); + return 1; + } + if (strstr(s_type, "output") != NULL && s_output == NULL) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" is an output stream and must have the \"output_interval\" attribute.", s_name); + fmt_err(msgbuf); + return 1; + } + if (strstr(s_type, "input") != NULL && strstr(s_type, "output") == NULL && s_output != NULL) { + snprintf(msgbuf, MSGSIZE, "input-only stream \"%s\" has the \"output_interval\" attribute.", s_name); + fmt_warn(msgbuf); + } + if (strstr(s_type, "output") != NULL && strstr(s_type, "input") == NULL && s_input != NULL) { + snprintf(msgbuf, MSGSIZE, "output-only stream \"%s\" has the \"input_interval\" attribute.", s_name); + fmt_warn(msgbuf); + } + + /* + * Check that filename_interval is given an acceptable value. + */ + if ( s_filename_intv != NULL ) { + if ( strstr(s_filename_intv, "input_interval") != NULL && s_input == NULL) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" has a value of \"input_interval\" for the \"filename_interval\" attribute, without defining the \"input_interval\" attribute.", s_name); + fmt_err(msgbuf); + return 1; + } + if ( strstr(s_filename_intv, "output_interval") != NULL && s_output == NULL) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" has a value of \"output_interval\" for the \"filename_interval\" attribute, without defining the \"output_interval\" attribute.", s_name); + fmt_err(msgbuf); + return 1; + } + if ( strstr(s_filename_intv, "input_interval") != NULL && strstr(s_input, "initial_only") != NULL) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" cannot have a value of \"input_interval\" for the \"filename_interval\" attribute, when \"input_interval\" is set to \"initial_only\".", s_name); + fmt_err(msgbuf); + return 1; + } + if ( strstr(s_filename_intv, "output_interval") != NULL && strstr(s_output, "initial_only") != NULL) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" cannot have a value of \"output_interval\" for the \"filename_interval\" attribute, when \"output_interval\" is set to \"initial_only\".", s_name); + fmt_err(msgbuf); + return 1; + } + } + + + /* + * Check that the filename template contains no illegal characters or variables + * NB: If new variable characters are added here, they should also be accommodated in + * the mpas_expand_string() subroutine in the mpas_timekeeping module. + */ + len = strlen(s_filename); + nextchar = 0; + for (i=(len-1); i>=0; nextchar=s_filename[i--]) { + if (s_filename[i] == '$') { + if (strchr("YMDdhmsG",nextchar) == NULL) { + snprintf(msgbuf, MSGSIZE, "filename_template for stream \"%s\" contains unrecognized variable \"$%c\".", s_name, nextchar); + fmt_err(msgbuf); + return 1; + } + } + } + + return 0; +} + + +/********************************************************************************* + * + * Function: uniqueness_check + * + * Checks that two streams have unique name and filename_template attributes + * + *********************************************************************************/ +int uniqueness_check(ezxml_t stream1, ezxml_t stream2) +{ + const char *name, *name2; + const char *filename, *filename2; + char msgbuf[MSGSIZE]; + + if (stream1 != stream2) { + name = ezxml_attr(stream1, "name"); + filename = ezxml_attr(stream1, "filename_template"); + name2 = ezxml_attr(stream2, "name"); + filename2 = ezxml_attr(stream2, "filename_template"); + + if (strcmp(name, name2) == 0) { + snprintf(msgbuf, MSGSIZE, "stream \"%s\" is define more than once.", name); + fmt_err(msgbuf); + return 1; + } + if (strcmp(filename, filename2) == 0) { + snprintf(msgbuf, MSGSIZE, "streams \"%s\" and \"%s\" cannot share the filename_template \"%s\".", name, name2, filename); + fmt_err(msgbuf); + return 1; + } + } + + return 0; +} + + +/********************************************************************************* + * + * Function: check_streams + * + * Validates the specification of run-time streams. + * + *********************************************************************************/ +int check_streams(ezxml_t streams) +{ + ezxml_t stream_xml; + ezxml_t stream2_xml; + ezxml_t test_xml; + ezxml_t test2_xml; + const char *name; + const char *filename; + char msgbuf[MSGSIZE]; + + + /* Check immutable streams */ + for (stream_xml = ezxml_child(streams, "immutable_stream"); stream_xml; stream_xml = ezxml_next(stream_xml)) { + if (attribute_check(stream_xml) != 0) { + return 1; + } + + /* Check that users are not attempting to add fields to an immutable stream */ + test_xml = ezxml_child(stream_xml, "var"); + test2_xml = ezxml_child(stream_xml, "file"); + if (test_xml != NULL || test2_xml != NULL) { + name = ezxml_attr(stream_xml, "name"); + snprintf(msgbuf, MSGSIZE, "the set of variables in stream \"%s\" cannot be modified.", name); + fmt_err(msgbuf); + return 1; + } + } + + /* Check mutable streams */ + for (stream_xml = ezxml_child(streams, "stream"); stream_xml; stream_xml = ezxml_next(stream_xml)) { + name = ezxml_attr(stream_xml, "name"); + + if (attribute_check(stream_xml) != 0) { + return 1; + } + + /* If fields are specified in a separate file, that file should exist */ + for (test_xml = ezxml_child(stream_xml, "file"); test_xml; test_xml = ezxml_next(test_xml)) { + filename = ezxml_attr(test_xml, "name"); +/* TODO: should this also be done only on the master task? */ + if (access(filename, F_OK|R_OK) == -1) { + snprintf(msgbuf, MSGSIZE, "definition of stream \"%s\" references file %s that cannot be opened for reading.", name, filename); + fmt_err(msgbuf); + return 1; + } + } + } + + + /* Check that the name and filename_template attributes of all streams are unique */ + for (stream_xml = ezxml_child(streams, "stream"); stream_xml; stream_xml = ezxml_next(stream_xml)) { + for (stream2_xml = ezxml_child(streams, "stream"); stream2_xml; stream2_xml = ezxml_next(stream2_xml)) { + if (uniqueness_check(stream_xml, stream2_xml)) return 1; + } + for (stream2_xml = ezxml_child(streams, "immutable_stream"); stream2_xml; stream2_xml = ezxml_next(stream2_xml)) { + if (uniqueness_check(stream_xml, stream2_xml)) return 1; + } + } + for (stream_xml = ezxml_child(streams, "immutable_stream"); stream_xml; stream_xml = ezxml_next(stream_xml)) { + for (stream2_xml = ezxml_child(streams, "stream"); stream2_xml; stream2_xml = ezxml_next(stream2_xml)) { + if (uniqueness_check(stream_xml, stream2_xml)) return 1; + } + for (stream2_xml = ezxml_child(streams, "immutable_stream"); stream2_xml; stream2_xml = ezxml_next(stream2_xml)) { + if (uniqueness_check(stream_xml, stream2_xml)) return 1; + } + } + + return 0; +} + + +/********************************************************************************* + * + * Function: xml_syntax_check + * + * Performs a few basic syntax checks on a buffer containing XML: + * 1) Are the angle brackets balanced? + * 2) Are the quotes balanced? + * 3) Are all XML tags closed and nested properly? + * + * There are clearly many syntax errors that this code will not catch, e.g., attribute + * values that contain no quotes at all; similarly, there are syntactically correct + * situations that this code will flag as bad, e.g., quoted strings that contain the + * '=' character. If we really wanted to be thorough, we should employ a proper parser + * with a well-specified grammar. + * + *********************************************************************************/ +int xml_syntax_check(char *xml_buf, size_t bufsize) +{ + size_t i; + size_t len; + int nleft, nright, line, start_line; + int nleftcom, nrightcom; + char msgbuf[MSGSIZE]; + char *tag_buf; + struct stacknode *node; + struct stacknode tmp_node; + + + /* + * Check that we have balanced angle brackets + */ + nleft = 0; + nright = 0; + nleftcom = 0; + nrightcom = 0; + line = 1; + + if ( xml_buf[0] == '>' ) { + snprintf(msgbuf, MSGSIZE, "line %i, unexpected starting \'>\' character. A file cannot start with a \'>\' character.", line); + fmt_err(msgbuf); + return 1; + } + + for (i=0; i 1) { + snprintf(msgbuf, MSGSIZE, "line %i, unexpected XML comment open. Is the previous XML comment missing a \'-->\'?", line); + fmt_err(msgbuf); + return 1; + } else if (nleft != nright) { + snprintf(msgbuf, MSGSIZE, "line %i, unexpected XML comment open. Is the previous XML tag missing a \'>\'?\n NOTE: Comments are not allowed within an open XML tag.", line); + fmt_err(msgbuf); + return 1; + } + } else { + nleft++; + if (nleft - nright > 1){ + snprintf(msgbuf, MSGSIZE, "line %i, unexpected \'<\' character. Is the previous XML tag missing a \'>\'?", line); + fmt_err(msgbuf); + return 1; + } + } + } + else if (xml_buf[i] == '>') { + if (i > 0 && xml_buf[i-1] == '-'){ + nrightcom++; + if (nleftcom != nrightcom) { + snprintf(msgbuf, MSGSIZE, "line %i, unexpected XML comment close. Is the XML comment missing a \' + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -66,9 +125,7 @@ - - - + @@ -102,8 +159,6 @@ - - diff --git a/src/registry/dictionary.c b/src/registry/dictionary.c index ec9b23ab4c..dc4d87db85 100644 --- a/src/registry/dictionary.c +++ b/src/registry/dictionary.c @@ -11,112 +11,106 @@ int hashstring(char *); -void dict_alloc(struct dtable ** dict) +void dict_alloc(struct dtable ** dict)/*{{{*/ { - int i; + int i; - *dict = (struct dtable *)malloc(sizeof(struct dtable)); - - for(i=0; itable[i] = NULL; - - (*dict)->size = 0; -} + *dict = (struct dtable *)malloc(sizeof(struct dtable)); + for(i=0; itable[i] = NULL; -void dict_insert(struct dtable * dict, char * word) -{ - int hval; - struct dnode * dptr; - - hval = hashstring(word) % TABLESIZE; - - dptr = (struct dnode *)malloc(sizeof(struct dnode)); - strncpy(dptr->key, word, 1024); - dptr->next = dict->table[hval]; - dict->table[hval] = dptr; + (*dict)->size = 0; +}/*}}}*/ - dict->size++; -} - - -void dict_remove(struct dtable * dict, char * word) +void dict_insert(struct dtable * dict, char * word)/*{{{*/ { - int hval; - struct dnode * dptr_prev; - struct dnode * dptr; - - hval = hashstring(word) % TABLESIZE; + int hval; + struct dnode * dptr; - dptr_prev = 0; - dptr = dict->table[hval]; + hval = hashstring(word) % TABLESIZE; - while (dptr && strncmp(dptr->key, word, 1024) != 0) { - dptr_prev = dptr; - dptr = dptr->next; - } + dptr = (struct dnode *)malloc(sizeof(struct dnode)); + strncpy(dptr->key, word, 1024); + dptr->next = dict->table[hval]; + dict->table[hval] = dptr; - if (dptr) { - if (dptr_prev) - dptr_prev->next = dptr->next; - else - dict->table[hval] = dict->table[hval]->next; - free(dptr); - dict->size--; - } -} + dict->size++; +}/*}}}*/ - -int dict_search(struct dtable * dict, char * word) +void dict_remove(struct dtable * dict, char * word)/*{{{*/ +{ + int hval; + struct dnode * dptr_prev; + struct dnode * dptr; + + hval = hashstring(word) % TABLESIZE; + + dptr_prev = 0; + dptr = dict->table[hval]; + + while (dptr && strncmp(dptr->key, word, 1024) != 0) { + dptr_prev = dptr; + dptr = dptr->next; + } + + if (dptr) { + if (dptr_prev) + dptr_prev->next = dptr->next; + else + dict->table[hval] = dict->table[hval]->next; + free(dptr); + dict->size--; + } +}/*}}}*/ + +int dict_search(struct dtable * dict, char * word)/*{{{*/ { - int hval; - struct dnode * dptr; + int hval; + struct dnode * dptr; - hval = hashstring(word) % TABLESIZE; + hval = hashstring(word) % TABLESIZE; - dptr = dict->table[hval]; - while (dptr && strncmp(dptr->key, word, 1024) != 0) - dptr = dptr->next; - - if (!dptr) return 0; + dptr = dict->table[hval]; + while (dptr && strncmp(dptr->key, word, 1024) != 0) + dptr = dptr->next; - return 1; -} + if (!dptr) return 0; + return 1; +}/*}}}*/ -int dict_size(struct dtable * dict) +int dict_size(struct dtable * dict)/*{{{*/ { - return dict->size; -} - + return dict->size; +}/*}}}*/ -void dict_free(struct dtable ** dict) +void dict_free(struct dtable ** dict)/*{{{*/ { - int i; - struct dnode * dptr; + int i; + struct dnode * dptr; - for(i=0; itable[i]) { - dptr = (*dict)->table[i]; - (*dict)->table[i] = (*dict)->table[i]->next; - free(dptr); - } - } + for(i=0; itable[i]) { + dptr = (*dict)->table[i]; + (*dict)->table[i] = (*dict)->table[i]->next; + free(dptr); + } + } - free(*dict); -} + free(*dict); +}/*}}}*/ - -int hashstring(char * word) +int hashstring(char * word)/*{{{*/ { - int i; - int hval; + int i; + int hval; + + hval = 0; - hval = 0; - - for(i=0; i<1024 && word[i] != '\0'; i++) { - hval = hval + (int)word[i]; - } + for(i=0; i<1024 && word[i] != '\0'; i++) { + hval = hval + (int)word[i]; + } - return hval; -} + return hval; +}/*}}}*/ diff --git a/src/registry/dictionary.h b/src/registry/dictionary.h index 3c697f4ea4..d7ff4dfe0e 100644 --- a/src/registry/dictionary.h +++ b/src/registry/dictionary.h @@ -9,13 +9,13 @@ #define TABLESIZE 271 struct dnode { - char key[1024]; - struct dnode * next; + char key[1024]; + struct dnode * next; }; struct dtable { - int size; - struct dnode * table[TABLESIZE]; + int size; + struct dnode * table[TABLESIZE]; }; void dict_alloc(struct dtable **); diff --git a/src/registry/fortprintf.c b/src/registry/fortprintf.c index baaff89d7c..9526d020de 100644 --- a/src/registry/fortprintf.c +++ b/src/registry/fortprintf.c @@ -9,9 +9,9 @@ #include #ifdef FORTPRINTF_TESTING - #define MAX_LINE_LEN 20 +#define MAX_LINE_LEN 20 #else - #define MAX_LINE_LEN 132 +#define MAX_LINE_LEN 132 #endif char printbuf[MAX_LINE_LEN+2]; @@ -23,272 +23,272 @@ int nbuf = 0; * than worrying about splitting strings at spaces */ -int fortprintf(FILE * fd, char * str, ...) +int fortprintf(FILE * fd, char * str, ...)/*{{{*/ { - int i, nl, sp, inquotes, q; - int lastchar; - int errorcode; - va_list ap; + int i, nl, sp, inquotes, q; + int lastchar; + int errorcode; + va_list ap; #ifdef FORTPRINTF_DEBUG - printf("call to fortprintf\n"); + printf("call to fortprintf\n"); #endif - /* Assume no errors */ - errorcode = 0; + /* Assume no errors */ + errorcode = 0; - /* Add formatted string to the buffer of fortran code to be written */ - va_start(ap, str); - i = vsnprintf(fbuffer+nbuf, 1024-nbuf, str, ap); - va_end(ap); + /* Add formatted string to the buffer of fortran code to be written */ + va_start(ap, str); + i = vsnprintf(fbuffer+nbuf, 1024-nbuf, str, ap); + va_end(ap); - /* Set the next free position in the fortran buffer */ - nbuf = nbuf + i; + /* Set the next free position in the fortran buffer */ + nbuf = nbuf + i; - inquotes = 0; - q = -1; + inquotes = 0; + q = -1; - do { + do { - nl = sp = -1; + nl = sp = -1; - /* Scan through the max line length - 1 (since we may have to add an & character) or the end of the buffer, whichever comes first */ - for (i=0; i= 0) { - snprintf(printbuf, nl+2, "%s", fbuffer); - fprintf(fd, "%s", printbuf); - nl++; - - /* Shift unprinted contents of fortran buffer to the beginning */ - for (i=0; nl= 0) { - snprintf(printbuf, sp+2, "%s", fbuffer); - i = sp+1; - if (inquotes && (sp > q)) printbuf[i++] = '\''; - printbuf[i++] = '&'; - printbuf[i++] = '\n'; - printbuf[i++] = '\0'; - fprintf(fd, "%s", printbuf); - sp++; - i = 0; - if (inquotes && (sp > q)) { - inquotes = (inquotes + 1) % 2; - fbuffer[i++] = '/'; - fbuffer[i++] = '/'; - fbuffer[i++] = '\''; - } - - /* Shift unprinted contents of fortran buffer to the beginning */ - for ( ; sp MAX_LINE_LEN) { - fprintf(fd, "!!! Error: Output could not be formatted by fortprintf() !!!\n"); - nbuf = 0; - errorcode = 1; - } - - } while (nl >= 0 || sp >= 0); - - return errorcode; -} - -void fortprint_flush(FILE * fd) + /* If we have a newline */ + if (nl >= 0) { + snprintf(printbuf, nl+2, "%s", fbuffer); + fprintf(fd, "%s", printbuf); + nl++; + + /* Shift unprinted contents of fortran buffer to the beginning */ + for (i=0; nl= 0) { + snprintf(printbuf, sp+2, "%s", fbuffer); + i = sp+1; + if (inquotes && (sp > q)) printbuf[i++] = '\''; + printbuf[i++] = '&'; + printbuf[i++] = '\n'; + printbuf[i++] = '\0'; + fprintf(fd, "%s", printbuf); + sp++; + i = 0; + if (inquotes && (sp > q)) { + inquotes = (inquotes + 1) % 2; + fbuffer[i++] = '/'; + fbuffer[i++] = '/'; + fbuffer[i++] = '\''; + } + + /* Shift unprinted contents of fortran buffer to the beginning */ + for ( ; sp MAX_LINE_LEN) { + fprintf(fd, "!!! Error: Output could not be formatted by fortprintf() !!!\n"); + nbuf = 0; + errorcode = 1; + } + + } while (nl >= 0 || sp >= 0); + + return errorcode; +}/*}}}*/ + +void fortprint_flush(FILE * fd)/*{{{*/ { - snprintf(printbuf, nbuf+1, "%s", fbuffer); - fprintf(fd, "%s", printbuf); - nbuf = 0; -} + snprintf(printbuf, nbuf+1, "%s", fbuffer); + fprintf(fd, "%s", printbuf); + nbuf = 0; +}/*}}}*/ #ifdef FORTPRINTF_TESTING -void print_result(int test_num, int err_code) +void print_result(int test_num, int err_code)/*{{{*/ { - if(err_code == 0){ - printf("Test %02d: PASSED\n", test_num); - } else { - printf("Test %02d: **FAILED\n", test_num); - } -} - -int main() + if(err_code == 0){ + printf("Test %02d: PASSED\n", test_num); + } else { + printf("Test %02d: **FAILED\n", test_num); + } +}/*}}}*/ + +int main()/*{{{*/ { - FILE * foo; - int err; - - /* Tests writing a line with NO space that is below the column limit */ - foo = fopen("test01.inc","w"); - err = fortprintf(foo, "123456789\n"); - print_result(1, err); - fclose(foo); - - /* Tests writing a line with space that is below the column limit */ - foo = fopen("test02.inc","w"); - err = fortprintf(foo, "12345 789\n"); - print_result(2, err); - fclose(foo); - - /*** Test lines that are less than 20 chars long ***/ - - /* Tests the case where we write a newline at the last column with chances to break the line earlier */ - foo = fopen("test03.inc","w"); - err = fortprintf(foo, "123456789 12345678\n"); - print_result(3, err); - fclose(foo); - - /* Tests the case where we write a newline at the last column with NO chances to break the line earlier */ - foo = fopen("test04.inc","w"); - err = fortprintf(foo, "123456789012345678\n"); - print_result(4, err); - fclose(foo); - - /* Tests a line with a space occurring in the NEXT-TO-LAST column plus another line */ - foo = fopen("test05.inc","w"); - err = fortprintf(foo, "123456789 1234567 0"); - err += fortprintf(foo, "1234\n"); - print_result(5, err); - fclose(foo); - - /* Tests a line with a space occurring in the LAST column plus another line */ - foo = fopen("test06.inc","w"); - err = fortprintf(foo, "123456789 12345678 "); - err += fortprintf(foo, "1234\n"); - print_result(6, err); - fclose(foo); - - /* Tests a line with the first space occurring in the NEXT-TO-LAST column plus another line */ - foo = fopen("test07.inc","w"); - err = fortprintf(foo, "12345678901234567 0"); - err += fortprintf(foo, "1234\n"); - print_result(7, err); - fclose(foo); - - /* Tests a line with the first space occurring in the LAST column plus another line */ - foo = fopen("test08.inc","w"); - err = fortprintf(foo, "123456789012345678 "); - err += fortprintf(foo, "1234\n"); - print_result(8, err); - fclose(foo); - - /*** Test lines that are exactly 20 chars long ***/ - - /* Tests the case where we write a newline at the last column with chances to break the line earlier */ - foo = fopen("test09.inc","w"); - err = fortprintf(foo, "123456789 123456789\n"); - print_result(9, err); - fclose(foo); - - /* Tests the case where we write a newline at the last column with NO chances to break the line earlier */ - foo = fopen("test10.inc","w"); - err = fortprintf(foo, "1234567890123456789\n"); - print_result(10, err); - fclose(foo); - - /* Tests a line with a space occurring in the NEXT-TO-LAST column plus another line */ - foo = fopen("test11.inc","w"); - err = fortprintf(foo, "123456789 12345678 0"); - err += fortprintf(foo, "1234\n"); - print_result(11, err); - fclose(foo); - - /* Tests a line with a space occurring in the LAST column plus another line */ - foo = fopen("test12.inc","w"); - err = fortprintf(foo, "123456789 123456780 "); - err += fortprintf(foo, "1234\n"); - print_result(12, err); - fclose(foo); - - /* Tests a line with the first space occurring in the NEXT-TO-LAST column plus another line */ - foo = fopen("test13.inc","w"); - err = fortprintf(foo, "123456789012345678 0"); - err += fortprintf(foo, "1234\n"); - print_result(13, err); - fclose(foo); - - /* Tests a line with the first space occurring in the LAST column plus another line */ - foo = fopen("test14.inc","w"); - err = fortprintf(foo, "1234567890123456780 "); - err += fortprintf(foo, "1234\n"); - print_result(14, err); - fclose(foo); - - /*** Test lines that are more than 21 chars long ***/ - - /* Tests the case where we write a newline at the last column with chances to break the line earlier */ - foo = fopen("test15.inc","w"); - err = fortprintf(foo, "123456789 1234567890\n"); - print_result(15, err); - fclose(foo); - - /* Tests the case where we write a newline at the last column with NO chances to break the line earlier */ - foo = fopen("test16.inc","w"); - err = fortprintf(foo, "1234567890123456789\n"); - print_result(16, err); - fclose(foo); - - /* Tests a line with a space occurring in the NEXT-TO-LAST column plus another line */ - foo = fopen("test17.inc","w"); - err = fortprintf(foo, "123456789 123456789 0"); - err = fortprintf(foo, "1234\n"); - print_result(17, err); - fclose(foo); - - /* Tests a line with a space occurring in the LAST column plus another line */ - foo = fopen("test18.inc","w"); - err = fortprintf(foo, "123456789 1234567890 "); - err += fortprintf(foo, "1234\n"); - print_result(18, err); - fclose(foo); - - /* Tests a line with the first space occurring in the NEXT-TO-LAST column plus another line */ - foo = fopen("test19.inc","w"); - err = fortprintf(foo, "1234567890123456789 0"); - err += fortprintf(foo, "1234\n"); - print_result(19, err); - fclose(foo); - - /* Tests a line with the first space occurring in the LAST column plus another line */ - foo = fopen("test20.inc","w"); - err = fortprintf(foo, "12345678901234567890 "); - err += fortprintf(foo, "1234\n"); - print_result(20, err); - fclose(foo); - - return 0; -} + FILE * foo; + int err; + + /* Tests writing a line with NO space that is below the column limit */ + foo = fopen("test01.inc","w"); + err = fortprintf(foo, "123456789\n"); + print_result(1, err); + fclose(foo); + + /* Tests writing a line with space that is below the column limit */ + foo = fopen("test02.inc","w"); + err = fortprintf(foo, "12345 789\n"); + print_result(2, err); + fclose(foo); + + /*** Test lines that are less than 20 chars long ***/ + + /* Tests the case where we write a newline at the last column with chances to break the line earlier */ + foo = fopen("test03.inc","w"); + err = fortprintf(foo, "123456789 12345678\n"); + print_result(3, err); + fclose(foo); + + /* Tests the case where we write a newline at the last column with NO chances to break the line earlier */ + foo = fopen("test04.inc","w"); + err = fortprintf(foo, "123456789012345678\n"); + print_result(4, err); + fclose(foo); + + /* Tests a line with a space occurring in the NEXT-TO-LAST column plus another line */ + foo = fopen("test05.inc","w"); + err = fortprintf(foo, "123456789 1234567 0"); + err += fortprintf(foo, "1234\n"); + print_result(5, err); + fclose(foo); + + /* Tests a line with a space occurring in the LAST column plus another line */ + foo = fopen("test06.inc","w"); + err = fortprintf(foo, "123456789 12345678 "); + err += fortprintf(foo, "1234\n"); + print_result(6, err); + fclose(foo); + + /* Tests a line with the first space occurring in the NEXT-TO-LAST column plus another line */ + foo = fopen("test07.inc","w"); + err = fortprintf(foo, "12345678901234567 0"); + err += fortprintf(foo, "1234\n"); + print_result(7, err); + fclose(foo); + + /* Tests a line with the first space occurring in the LAST column plus another line */ + foo = fopen("test08.inc","w"); + err = fortprintf(foo, "123456789012345678 "); + err += fortprintf(foo, "1234\n"); + print_result(8, err); + fclose(foo); + + /*** Test lines that are exactly 20 chars long ***/ + + /* Tests the case where we write a newline at the last column with chances to break the line earlier */ + foo = fopen("test09.inc","w"); + err = fortprintf(foo, "123456789 123456789\n"); + print_result(9, err); + fclose(foo); + + /* Tests the case where we write a newline at the last column with NO chances to break the line earlier */ + foo = fopen("test10.inc","w"); + err = fortprintf(foo, "1234567890123456789\n"); + print_result(10, err); + fclose(foo); + + /* Tests a line with a space occurring in the NEXT-TO-LAST column plus another line */ + foo = fopen("test11.inc","w"); + err = fortprintf(foo, "123456789 12345678 0"); + err += fortprintf(foo, "1234\n"); + print_result(11, err); + fclose(foo); + + /* Tests a line with a space occurring in the LAST column plus another line */ + foo = fopen("test12.inc","w"); + err = fortprintf(foo, "123456789 123456780 "); + err += fortprintf(foo, "1234\n"); + print_result(12, err); + fclose(foo); + + /* Tests a line with the first space occurring in the NEXT-TO-LAST column plus another line */ + foo = fopen("test13.inc","w"); + err = fortprintf(foo, "123456789012345678 0"); + err += fortprintf(foo, "1234\n"); + print_result(13, err); + fclose(foo); + + /* Tests a line with the first space occurring in the LAST column plus another line */ + foo = fopen("test14.inc","w"); + err = fortprintf(foo, "1234567890123456780 "); + err += fortprintf(foo, "1234\n"); + print_result(14, err); + fclose(foo); + + /*** Test lines that are more than 21 chars long ***/ + + /* Tests the case where we write a newline at the last column with chances to break the line earlier */ + foo = fopen("test15.inc","w"); + err = fortprintf(foo, "123456789 1234567890\n"); + print_result(15, err); + fclose(foo); + + /* Tests the case where we write a newline at the last column with NO chances to break the line earlier */ + foo = fopen("test16.inc","w"); + err = fortprintf(foo, "1234567890123456789\n"); + print_result(16, err); + fclose(foo); + + /* Tests a line with a space occurring in the NEXT-TO-LAST column plus another line */ + foo = fopen("test17.inc","w"); + err = fortprintf(foo, "123456789 123456789 0"); + err = fortprintf(foo, "1234\n"); + print_result(17, err); + fclose(foo); + + /* Tests a line with a space occurring in the LAST column plus another line */ + foo = fopen("test18.inc","w"); + err = fortprintf(foo, "123456789 1234567890 "); + err += fortprintf(foo, "1234\n"); + print_result(18, err); + fclose(foo); + + /* Tests a line with the first space occurring in the NEXT-TO-LAST column plus another line */ + foo = fopen("test19.inc","w"); + err = fortprintf(foo, "1234567890123456789 0"); + err += fortprintf(foo, "1234\n"); + print_result(19, err); + fclose(foo); + + /* Tests a line with the first space occurring in the LAST column plus another line */ + foo = fopen("test20.inc","w"); + err = fortprintf(foo, "12345678901234567890 "); + err += fortprintf(foo, "1234\n"); + print_result(20, err); + fclose(foo); + + return 0; +}/*}}}*/ #endif diff --git a/src/registry/gen_inc.c b/src/registry/gen_inc.c index f2462c971f..81a8617ea3 100644 --- a/src/registry/gen_inc.c +++ b/src/registry/gen_inc.c @@ -8,1722 +8,2627 @@ #include #include #include -#include "dictionary.h" +#include +#include "ezxml/ezxml.h" #include "registry_types.h" #include "gen_inc.h" #include "fortprintf.h" +#include "utility.h" -int is_derived_dim(char * d) -{ - if (strchr(d, (int)'+')) return 1; - if (strchr(d, (int)'-')) return 1; +#define STR(s) #s +#define MACRO_TO_STR(s) STR(s) - return 0; -} +void write_model_variables(ezxml_t registry){/*{{{*/ + const char * suffix = MACRO_TO_STR(MPAS_NAMELIST_SUFFIX); + const char * exe_name = MACRO_TO_STR(MPAS_EXE_NAME); + const char * git_ver = MACRO_TO_STR(MPAS_GIT_VERSION); + const char *modelname, *corename, *version; + FILE *fd; -void get_outer_dim(struct variable * var, char * last_dim) -{ - struct dimension_list * dimlist_ptr; - + modelname = ezxml_attr(registry, "model"); + corename = ezxml_attr(registry, "core"); + version = ezxml_attr(registry, "version"); - dimlist_ptr = var->dimlist; - while (dimlist_ptr->next) dimlist_ptr = dimlist_ptr->next; + fd = fopen("model_variables.inc", "w+"); - strcpy(last_dim, dimlist_ptr->dim->name_in_file); -} + fortprintf(fd, " character (len=StrKIND) :: modelName = '%s' !< Constant: Name of model\n", modelname); + fortprintf(fd, " character (len=StrKIND) :: coreName = '%s' !< Constant: Name of core\n", corename); + fortprintf(fd, " character (len=StrKIND) :: modelVersion = '%s' !< Constant: Version number\n", version); + fortprintf(fd, " character (len=StrKIND) :: namelist_filename = 'namelist.%s' !< Constant: Name of namelist file\n", suffix); + fortprintf(fd, " character (len=StrKIND) :: streams_filename = 'streams.%s' !< Constant: Name of stream configuration file\n", suffix); + fortprintf(fd, " character (len=StrKIND) :: executableName = '%s' !< Constant: Name of executable generated at build time.\n", exe_name); + fortprintf(fd, " character (len=StrKIND) :: git_version = '%s' !< Constant: Version string from git-describe.\n", git_ver); -void split_derived_dim_string(char * dim, char ** p1, char ** p2) -{ - char * cp, * cm, * c; - int n; + fclose(fd); +}/*}}}*/ + + +int write_field_pointers(FILE* fd){/*{{{*/ + fortprintf(fd, "\n"); + fortprintf(fd, " type (field0DReal), pointer :: r0Ptr\n"); + fortprintf(fd, " type (field1DReal), pointer :: r1Ptr\n"); + fortprintf(fd, " type (field2DReal), pointer :: r2Ptr\n"); + fortprintf(fd, " type (field3DReal), pointer :: r3Ptr\n"); + fortprintf(fd, " type (field4DReal), pointer :: r4Ptr\n"); + fortprintf(fd, " type (field5DReal), pointer :: r5Ptr\n"); + fortprintf(fd, " type (field0DInteger), pointer :: i0Ptr\n"); + fortprintf(fd, " type (field1DInteger), pointer :: i1Ptr\n"); + fortprintf(fd, " type (field2DInteger), pointer :: i2Ptr\n"); + fortprintf(fd, " type (field3DInteger), pointer :: i3Ptr\n"); + fortprintf(fd, " type (field0DChar), pointer :: c0Ptr\n"); + fortprintf(fd, " type (field1DChar), pointer :: c1Ptr\n"); + fortprintf(fd, "\n"); + + return 0; +}/*}}}*/ + + +int write_field_pointer_arrays(FILE* fd){/*{{{*/ + fortprintf(fd, "\n"); + fortprintf(fd, " type (field0DReal), dimension(:), pointer :: r0Ptr\n"); + fortprintf(fd, " type (field1DReal), dimension(:), pointer :: r1Ptr\n"); + fortprintf(fd, " type (field2DReal), dimension(:), pointer :: r2Ptr\n"); + fortprintf(fd, " type (field3DReal), dimension(:), pointer :: r3Ptr\n"); + fortprintf(fd, " type (field4DReal), dimension(:), pointer :: r4Ptr\n"); + fortprintf(fd, " type (field5DReal), dimension(:), pointer :: r5Ptr\n"); + fortprintf(fd, " type (field0DInteger), dimension(:), pointer :: i0Ptr\n"); + fortprintf(fd, " type (field1DInteger), dimension(:), pointer :: i1Ptr\n"); + fortprintf(fd, " type (field2DInteger), dimension(:), pointer :: i2Ptr\n"); + fortprintf(fd, " type (field3DInteger), dimension(:), pointer :: i3Ptr\n"); + fortprintf(fd, " type (field0DChar), dimension(:), pointer :: c0Ptr\n"); + fortprintf(fd, " type (field1DChar), dimension(:), pointer :: c1Ptr\n"); + fortprintf(fd, "\n"); + + return 0; +}/*}}}*/ + + +int set_pointer_name(int type, int ndims, char *pointer_name){/*{{{*/ + if(type == REAL) { + switch (ndims){ + default: + case 0: + snprintf(pointer_name, 1024, "r0Ptr"); + break; + case 1: + snprintf(pointer_name, 1024, "r1Ptr"); + break; + case 2: + snprintf(pointer_name, 1024, "r2Ptr"); + break; + case 3: + snprintf(pointer_name, 1024, "r3Ptr"); + break; + case 4: + snprintf(pointer_name, 1024, "r4Ptr"); + break; + case 5: + snprintf(pointer_name, 1024, "r5Ptr"); + break; + } + } else if (type == INTEGER) { + switch (ndims){ + default: + case 0: + snprintf(pointer_name, 1024, "i0Ptr"); + break; + case 1: + snprintf(pointer_name, 1024, "i1Ptr"); + break; + case 2: + snprintf(pointer_name, 1024, "i2Ptr"); + break; + case 3: + snprintf(pointer_name, 1024, "i3Ptr"); + break; + } + } else if (type == CHARACTER) { + switch (ndims){ + default: + case 0: + snprintf(pointer_name, 1024, "c0Ptr"); + break; + case 1: + snprintf(pointer_name, 1024, "c1Ptr"); + break; + } + } + + return 0; +}/*}}}*/ + + +int add_package_to_list(const char * package, const char * package_list){/*{{{*/ + char *token, *string, *tofree; + + string = strdup(package_list); + tofree = string; + token = strsep(&string, ";"); + + if(strcmp(package, token) == 0){ + return 0; + } + + while( (token = strsep(&string, ";")) != NULL){ + if(strcmp(package, token) == 0){ + + return 0; + } + } + + return 1; +}/*}}}*/ + + +int build_struct_package_lists(ezxml_t currentPosition, char * out_packages){/*{{{*/ + ezxml_t child_xml1, child_xml2; + + const char *package_list; + const char *name; + + char *token, *string, *tofree; + int empty_packages; + int empty_struct; + + package_list = ezxml_attr(currentPosition, "packages"); + + empty_packages = 0; + empty_struct = 1; + + // Check for vars that don't have packages. + for(child_xml1 = ezxml_child(currentPosition, "var"); child_xml1 && !empty_packages; child_xml1 = child_xml1->next){ + package_list = ezxml_attr(child_xml1, "packages"); + + if(!package_list){ + empty_packages = 1; + } + empty_struct = 0; + } + + // Check for vararrays and constituents that don't have packages. + for(child_xml1 = ezxml_child(currentPosition, "var_array"); child_xml1 && !empty_packages; child_xml1 = child_xml1->next){ + package_list = ezxml_attr(child_xml1, "packages"); + + if(!package_list){ + for(child_xml2 = ezxml_child(child_xml1, "var"); child_xml2 && !empty_packages; child_xml2 = child_xml2->next){ + package_list = ezxml_attr(child_xml2, "packages"); + + if(!package_list){ + empty_packages = 1; + } + empty_struct = 0; + } + } + } + + // If any var/var_array doesn't have packages on it, the struct doesn't have packages on it. + if(empty_packages || empty_struct){ + return 1; + } else { + // Build unique list of packages from nested vars and var arrays. + for(child_xml1 = ezxml_child(currentPosition, "var_array"); child_xml1; child_xml1 = child_xml1->next){ + package_list = ezxml_attr(child_xml1, "packages"); + + // Build list of unique packages from var_array + if(package_list){ + string = strdup(package_list); + tofree = string; + token = strsep(&string, ";"); + + if(out_packages[0] == '\0'){ + sprintf(out_packages, "%s", token); + } else if(add_package_to_list(token, out_packages)){ + sprintf(out_packages, "%s;%s", out_packages, token); + } + + while( (token = strsep(&string, ";")) != NULL){ + if(add_package_to_list(token, out_packages)){ + sprintf(out_packages, "%s;%s", out_packages, token); + } + } + + free(tofree); + } + + for(child_xml2 = ezxml_child(child_xml1, "var"); child_xml2; child_xml2 = child_xml2->next){ + package_list = ezxml_attr(child_xml2, "packages"); + + // Build list of unique packages from child var + if(package_list){ + string = strdup(package_list); + tofree = string; + token = strsep(&string, ";"); + + if(out_packages[0] == '\0'){ + sprintf(out_packages, "%s", token); + } else if(add_package_to_list(token, out_packages)){ + sprintf(out_packages, "%s;%s", out_packages, token); + } + + while( (token = strsep(&string, ";")) != NULL){ + if(add_package_to_list(token, out_packages)){ + sprintf(out_packages, "%s;%s", out_packages, token); + } + } + + free(tofree); + } + } + } + + for(child_xml1 = ezxml_child(currentPosition, "var"); child_xml1; child_xml1 = child_xml1->next){ + package_list = ezxml_attr(child_xml1, "packages"); - cp = strchr(dim, (int)'+'); - cm = strchr(dim, (int)'-'); - if (!cp) - c = cm; - else if (!cm) - c = cp; - else if (cm < cp) - c = cm; - else - c = cp; + // Build list of unique packages from child var + if(package_list){ + string = strdup(package_list); + tofree = string; + token = strsep(&string, ";"); - n = c - dim; - *p1 = (char *)malloc(n*sizeof(char)); - snprintf(*p1, n, "%s", dim+1); + if(out_packages[0] == '\0'){ + sprintf(out_packages, "%s", token); + } else if(add_package_to_list(token, out_packages)){ + sprintf(out_packages, "%s;%s", out_packages, token); + } - *p2 = (char *)malloc((strlen(dim)-n+1)*sizeof(char)); - sprintf(*p2, "%s", dim+n); -} + while( (token = strsep(&string, ";")) != NULL){ + if(add_package_to_list(token, out_packages)){ + sprintf(out_packages, "%s;%s", out_packages, token); + } + } -void write_package_options(FILE *fd, struct package * pkgs){ - struct package * pkg_ptr; + free(tofree); + } + } + return 0; + } +}/*}}}*/ + + +int get_dimension_information(const char *dims, int *ndims, int *has_time, int *decomp){/*{{{*/ + char *string, *tofree, *token; + + (*ndims) = 0; + (*decomp) = -1; + (*has_time) = 0; + string = strdup(dims); + tofree = string; + token = strsep(&string, " "); + if(strlen(token) > 0){ + if(strcmp(token, "Time") != 0){ + if(strcmp(token, "nCells") == 0){ + if((*decomp) == -1){ + (*decomp) = CELLS; + } else { + printf("ERROR: Multiple decomposition types\n"); + return 1; + } + } else if (strcmp(token, "nEdges") == 0){ + if((*decomp) == -1){ + (*decomp) = EDGES; + } else { + printf("ERROR: Multiple decomposition types\n"); + return 1; + } + } else if (strcmp(token, "nVertices") == 0){ + if((*decomp) == -1){ + (*decomp) = VERTICES; + } else { + printf("ERROR: Multiple decomposition types\n"); + return 1; + } + } + (*ndims)++; + } else { + (*has_time) = 1; + } + } + while( (token = strsep(&string, " ")) != NULL){ + if(strcmp(token, "Time") != 0){ + if(strcmp(token, "nCells") == 0){ + if((*decomp) == -1){ + (*decomp) = CELLS; + } else { + printf("ERROR: Multiple decomposition types\n"); + return 1; + } + } else if (strcmp(token, "nEdges") == 0){ + if((*decomp) == -1){ + (*decomp) = EDGES; + } else { + printf("ERROR: Multiple decomposition types\n"); + return 1; + } + } else if (strcmp(token, "nVertices") == 0){ + if((*decomp) == -1){ + (*decomp) = VERTICES; + } else { + printf("ERROR: Multiple decomposition types\n"); + return 1; + } + } + (*ndims)++; + } else { + (*has_time) = 1; + } + } + free(tofree); - pkg_ptr = pkgs; + return 0; +}/*}}}*/ - fortprintf(fd, "%sActive", pkg_ptr->name); - for (pkg_ptr = pkgs->next; pkg_ptr; pkg_ptr = pkg_ptr->next){ - fortprintf(fd, " .or. %sActive", pkg_ptr->name); +int get_field_information(const char *vartype, const char *varval, char *default_value, int *type){/*{{{*/ + if (strcmp(vartype, "real") == 0){ + (*type) = REAL; + if(!varval){ + snprintf(default_value, 1024, "0.0"); + } else { + snprintf(default_value, 1024, "%s", varval); + } + } else if (strcmp(vartype, "integer") == 0){ + (*type) = INTEGER; + if(!varval){ + snprintf(default_value, 1024, "0"); + } else { + snprintf(default_value, 1024, "%s", varval); + } + } else if (strcmp(vartype, "text") == 0){ + (*type) = CHARACTER; + if(!varval){ + snprintf(default_value, 1024, "''"); + } else { + snprintf(default_value, 1024, "%s", varval); + } } -} -void gen_namelists(struct namelist * nls) + return 0; +}/*}}}*/ + + +void write_default_namelist(ezxml_t registry) /*{{{*/ { - struct namelist * nls_ptr; - struct dtable * dictionary; - int done; - char nlrecord[1024]; - FILE * fd; - - /* - * Generate config_type.inc - */ - fd = fopen("config_defs.inc", "w"); - - nls_ptr = nls; - while (nls_ptr) { - if (nls_ptr->vtype == INTEGER) fortprintf(fd, " integer :: %s\n",nls_ptr->name); - if (nls_ptr->vtype == REAL) fortprintf(fd, " real (KIND=RKIND) :: %s\n",nls_ptr->name); - if (nls_ptr->vtype == LOGICAL) fortprintf(fd, " logical :: %s\n",nls_ptr->name); - if (nls_ptr->vtype == CHARACTER) fortprintf(fd, " character (len=StrKIND) :: %s\n",nls_ptr->name); - - nls_ptr = nls_ptr->next; - } - - fclose(fd); - - - /* - * Generate namelist_defs.inc - */ - fd = fopen("config_namelist_defs.inc", "w"); - dict_alloc(&dictionary); - - done = 0; - - while (!done) { - nls_ptr = nls; - while (nls_ptr && dict_search(dictionary, nls_ptr->record)) - nls_ptr = nls_ptr->next; - - if (nls_ptr) { - dict_insert(dictionary, nls_ptr->record); - strncpy(nlrecord, nls_ptr->record, 1024); - fortprintf(fd, " namelist /%s/ %s", nls_ptr->record, nls_ptr->name); - nls_ptr = nls_ptr->next; - while(nls_ptr) { - if (strncmp(nls_ptr->record, nlrecord, 1024) == 0) - fortprintf(fd, ", &\n %s", nls_ptr->name); - nls_ptr = nls_ptr->next; - } - fortprintf(fd, "\n"); - } - else - done = 1; - } - - - dict_free(&dictionary); - fclose(fd); - - - /* - * Generate namelist_reads.inc - */ - fd = fopen("config_set_defaults.inc", "w"); - nls_ptr = nls; - while (nls_ptr) { - if (nls_ptr->vtype == INTEGER) fortprintf(fd, " %s = %i\n", nls_ptr->name, nls_ptr->defval.ival); - if (nls_ptr->vtype == REAL) fortprintf(fd, " %s = %f\n", nls_ptr->name, nls_ptr->defval.rval); - if (nls_ptr->vtype == LOGICAL) { - if (nls_ptr->defval.lval == 0) - fortprintf(fd, " %s = .false.\n", nls_ptr->name); - else - fortprintf(fd, " %s = .true.\n", nls_ptr->name); - } - if (nls_ptr->vtype == CHARACTER) - fortprintf(fd, " %s = \"%s\"\n", nls_ptr->name, nls_ptr->defval.cval); - nls_ptr = nls_ptr->next; - } - fortprintf(fd, "\n"); - fclose(fd); - - - fd = fopen("config_namelist_reads.inc", "w"); - dict_alloc(&dictionary); - nls_ptr = nls; - while (nls_ptr) { - if (!dict_search(dictionary, nls_ptr->record)) { - fortprintf(fd, " read(funit,%s,iostat=ierr)\n", nls_ptr->record); - fortprintf(fd, " if (ierr > 0) then\n"); - fortprintf(fd, " write(0,*) \'Error while reading namelist record &%s\'\n",nls_ptr->record); - fortprintf(fd, " call mpas_dmpar_abort(dminfo)\n"); - fortprintf(fd, " else if (ierr < 0) then\n"); - fortprintf(fd, " write(0,*) \'Namelist record &%s not found; using default values for this namelist\'\'s variables\'\n",nls_ptr->record); - fortprintf(fd, " end if\n"); - fortprintf(fd, " rewind(funit)\n"); - - dict_insert(dictionary, nls_ptr->record); - } - nls_ptr = nls_ptr->next; - } - fortprintf(fd, "\n"); - - dict_free(&dictionary); - fclose(fd); - - - fd = fopen("config_bcast_namelist.inc", "w"); - nls_ptr = nls; - while (nls_ptr) { - if (nls_ptr->vtype == INTEGER) fortprintf(fd, " call mpas_dmpar_bcast_int(dminfo, %s)\n", nls_ptr->name); - if (nls_ptr->vtype == REAL) fortprintf(fd, " call mpas_dmpar_bcast_real(dminfo, %s)\n", nls_ptr->name); - if (nls_ptr->vtype == LOGICAL) fortprintf(fd, " call mpas_dmpar_bcast_logical(dminfo, %s)\n", nls_ptr->name); - if (nls_ptr->vtype == CHARACTER) fortprintf(fd, " call mpas_dmpar_bcast_char(dminfo, %s)\n", nls_ptr->name); - nls_ptr = nls_ptr->next; - } - fortprintf(fd, "\n"); - fclose(fd); -} - -void gen_history_attributes(char * modelname, char * corename, char * version) + ezxml_t rec_xml, opt_xml; + + const char *recname, *optname, *opttype, *optdefault; + const char *recindef, *optindef; + FILE *fd; + char filename[1024]; + const char * suffix = MACRO_TO_STR(MPAS_NAMELIST_SUFFIX); + int print_record, print_option; + + + sprintf(filename, "namelist.%s.defaults", suffix); + fd = fopen(filename, "w+"); + + for(rec_xml = ezxml_child(registry, "nml_record"); rec_xml; rec_xml = rec_xml->next){ + recname = ezxml_attr(rec_xml, "name"); + recindef = ezxml_attr(rec_xml, "in_defaults"); + + print_record = 1; + + if(recindef){ + if(strcmp(recindef, "true") != 0){ + print_record = 0; + } + } + + if(print_record) { + fprintf(fd, "&%s\n", recname); + for(opt_xml = ezxml_child(rec_xml, "nml_option"); opt_xml; opt_xml = opt_xml->next){ + optname = ezxml_attr(opt_xml, "name"); + opttype = ezxml_attr(opt_xml, "type"); + optdefault = ezxml_attr(opt_xml, "default_value"); + optindef = ezxml_attr(opt_xml, "in_defaults"); + + print_option = 1; + + if (optindef) { + if (strcmp(optindef, "true") != 0){ + print_option = 0; + } + } + + if(print_option){ + if (strcmp(opttype, "real") == 0){ + fprintf(fd, " %s = %s\n", optname, optdefault); + } else if (strcmp(opttype, "integer") == 0){ + fprintf(fd, " %s = %s\n", optname, optdefault); + } else if (strcmp(opttype, "logical") == 0){ + if (strcmp(optdefault, "true") == 0 || strcmp(optdefault, ".true.") == 0){ + fprintf(fd, " %s = .true.\n", optname); + } else { + fprintf(fd, " %s = .false.\n", optname); + } + } else if (strcmp(opttype, "character") == 0){ + fprintf(fd, " %s = '%s'\n", optname, optdefault); + } + } + } + fprintf(fd, "/\n\n"); + } + } + + fclose(fd); +}/*}}}*/ + + +void write_default_streams(ezxml_t registry){/*{{{*/ + ezxml_t streams_xml, varstruct_xml, opt_xml, var_xml, vararray_xml, stream_xml; + + const char *optstream, *optname, *optvarname, *opttype; + const char *optimmutable, *optfilename, *optfilename_interval, *optinterval_in, *optinterval_out, *optruntime, *optpackages; + const char *optref_time, *optprecision, *optrecord_interval, *optclobber_mode; + FILE *fd, *fd2; + char filename[64], filename2[64]; + const char * suffix = MACRO_TO_STR(MPAS_NAMELIST_SUFFIX); + + + sprintf(filename, "streams.%s.defaults", suffix); + fd = fopen(filename, "w"); + + fprintf(stderr, "Generating run-time stream definitions\n"); + + fprintf(fd, "\n\n"); + for (streams_xml = ezxml_child(registry, "streams"); streams_xml; streams_xml = streams_xml->next) { + for (opt_xml = ezxml_child(streams_xml, "stream"); opt_xml; opt_xml = opt_xml->next) { + optname = ezxml_attr(opt_xml, "name"); + opttype = ezxml_attr(opt_xml, "type"); + optfilename = ezxml_attr(opt_xml, "filename_template"); + optfilename_interval = ezxml_attr(opt_xml, "filename_interval"); + optinterval_in = ezxml_attr(opt_xml, "input_interval"); + optinterval_out = ezxml_attr(opt_xml, "output_interval"); + optimmutable = ezxml_attr(opt_xml, "immutable"); + optruntime = ezxml_attr(opt_xml, "runtime_format"); + optpackages = ezxml_attr(opt_xml, "packages"); + optprecision = ezxml_attr(opt_xml, "precision"); + optref_time = ezxml_attr(opt_xml, "reference_time"); + optrecord_interval = ezxml_attr(opt_xml, "record_interval"); + optclobber_mode = ezxml_attr(opt_xml, "clobber_mode"); + + /* Generate immutable default stream */ + if (optimmutable != NULL && strcmp(optimmutable, "true") == 0) { + fprintf(fd, "\n\n"); + } + else { + fprintf(fd, "\n\n"); + + /* + * Depending on the runtime format, we either generate a separate list of fields for + * each stream, or we list the fields directly in the main stream control file + */ + + if (strcmp(optruntime,"single_file") == 0) { + + /* Loop over streams listed within the stream */ + for (stream_xml = ezxml_child(opt_xml, "stream"); stream_xml; stream_xml = stream_xml->next){ + optname = ezxml_attr(stream_xml, "name"); + fprintf(fd, " \n", optname); + } + + /* Loop over fields looking for any that belong to the stream */ + for (varstruct_xml = ezxml_child(registry, "var_struct"); varstruct_xml; varstruct_xml = varstruct_xml->next) { + for (var_xml = ezxml_child(varstruct_xml, "var"); var_xml; var_xml = var_xml->next) { + optstream = ezxml_attr(var_xml, "streams"); + if (optstream != NULL && strstr(optstream, optname) != NULL) { + optvarname = ezxml_attr(var_xml, "name"); + fprintf(fd, " \n", optvarname); + } + } + } + + /* Loop over var_arrays listed within the stream */ + for (vararray_xml = ezxml_child(opt_xml, "var_array"); vararray_xml; vararray_xml = vararray_xml->next){ + optname = ezxml_attr(vararray_xml, "name"); + fprintf(fd, " \n", optname); + } + + /* Loop over fields listed within the stream */ + for (var_xml = ezxml_child(opt_xml, "var"); var_xml; var_xml = var_xml->next) { + optname = ezxml_attr(var_xml, "name"); + fprintf(fd, " \n", optname); + } + } + else if (strcmp(optruntime,"separate_file") == 0) { + + sprintf(filename2, "stream_list.%s.%s", suffix, optname); + + fprintf(fd, " \n", filename2); + + fd2 = fopen(filename2, "w+"); + + /* Loop over streams listed within the stream */ + for (stream_xml = ezxml_child(opt_xml, "stream"); stream_xml; stream_xml = stream_xml->next){ + optname = ezxml_attr(stream_xml, "name"); + fprintf(fd, " \n", optname); + } + + /* Loop over fields looking for any that belong to the stream */ + for (varstruct_xml = ezxml_child(registry, "var_struct"); varstruct_xml; varstruct_xml = varstruct_xml->next) { + for (var_xml = ezxml_child(varstruct_xml, "var"); var_xml; var_xml = var_xml->next) { + optstream = ezxml_attr(var_xml, "streams"); + if (optstream != NULL && strstr(optstream, optname) != NULL) { + optvarname = ezxml_attr(var_xml, "name"); + fprintf(fd2, "%s\n", optvarname); + } + } + } + + /* Loop over var_arrays listed within the stream */ + for (vararray_xml = ezxml_child(opt_xml, "var_array"); vararray_xml; vararray_xml = vararray_xml->next){ + optname = ezxml_attr(vararray_xml, "name"); + fprintf(fd2, "%s\n", optname); + } + + /* Loop over fields listed within the stream */ + for (var_xml = ezxml_child(opt_xml, "var"); var_xml; var_xml = var_xml->next) { + optname = ezxml_attr(var_xml, "name"); + fprintf(fd2, "%s\n", optname); + } + + fclose(fd2); + + } + else { + fprintf(stderr, "******************************************************\n"); + fprintf(stderr, "Error in specification of stream_format; this probably \n"); + fprintf(stderr, "should have been caught during validation...\n"); + fprintf(stderr, "******************************************************\n"); + } + + fprintf(fd, "\n"); + fprintf(fd, "\n\n"); + } + } + } + fprintf(fd, "\n"); + + fclose(fd); +}/*}}}*/ + + +int parse_packages_from_registry(ezxml_t registry)/*{{{*/ { + ezxml_t packages_xml, package_xml; + + const char *packagename, *packagedesc, *const_core; FILE *fd; + char core_string[1024]; + + const_core = ezxml_attr(registry, "core"); + + fd = fopen("define_packages.inc", "w+"); + + sprintf(core_string, "_%s_", const_core); + + // For now, don't include core name in subroutines + sprintf(core_string, "_"); + + + fortprintf(fd, " subroutine mpas_generate%spackages(packagePool)\n", core_string); + fortprintf(fd, " type (mpas_pool_type), intent(inout) :: packagePool !< Input: MPAS Pool for containing package logicals.\n\n"); + + // Parse Packages + for (packages_xml = ezxml_child(registry, "packages"); packages_xml; packages_xml = packages_xml->next){ + for (package_xml = ezxml_child(packages_xml, "package"); package_xml; package_xml = package_xml->next){ + packagename = ezxml_attr(package_xml, "name"); + packagedesc = ezxml_attr(package_xml, "description"); + + fortprintf(fd, " call mpas_pool_add_package(packagePool, '%sActive', .false.)\n", packagename); + } + } + + fortprintf(fd, " end subroutine mpas_generate%spackages\n", core_string); - fd = fopen("model_variables.inc","w"); - fortprintf(fd, " character (len=StrKIND) :: modelName = '%s' !< Constant: Name of model\n", modelname); - fortprintf(fd, " character (len=StrKIND) :: coreName = '%s' !< Constant: Name of core\n", corename); - fortprintf(fd, " character (len=StrKIND) :: modelVersion = '%s' !< Constant: Version number\n", version); fclose(fd); -} + + return 0; +}/*}}}*/ -void gen_field_defs(struct group_list * groups, struct variable * vars, struct dimension * dims) +int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ { - struct variable * var_ptr; - struct variable * var_ptr2; - struct variable_list * var_list_ptr; - struct variable_list * var_list_ptr2; - struct variable_list * var_list_ptr3; - struct dimension * dim_ptr; - struct dimension_list * dimlist_ptr; - struct group_list * group_ptr; - FILE * fd, *fd2; - char var_array[1024]; - char array_class[1024]; - char outer_dim[1024]; - int i, new_class; - int class_start, class_end; - int vtype; - char type_str[7]; - - - /* - * Generate declarations of dimensions - */ - fd = fopen("field_dimensions.inc", "w"); - dim_ptr = dims; - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %s\n", dim_ptr->name_in_code); - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %s\n", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - dim_ptr = dims; - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " integer :: %sSolve\n", dim_ptr->name_in_code); - fortprintf(fd, " integer, dimension(:), pointer :: %sArray\n", dim_ptr->name_in_code); - } - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " integer :: %sSolve\n", dim_ptr->name_in_file); - } - dim_ptr = dim_ptr->next; - } - - fclose(fd); - - /* - * Generate dummy dimension argument list - */ - fd = fopen("dim_dummy_args.inc", "w"); - dim_ptr = dims; - if (dim_ptr && dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " %s", dim_ptr->name_in_code); - dim_ptr = dim_ptr->next; - } - else if (dim_ptr && dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " %s", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_code); - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - fortprintf(fd, " &\n"); - - fclose(fd); - - /* - * Generate dummy dimension argument declaration list - */ - fd = fopen("dim_dummy_decls.inc", "w"); - dim_ptr = dims; - if (dim_ptr && dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " integer, intent(in) :: %s", dim_ptr->name_in_code); - dim_ptr = dim_ptr->next; - } - else if (dim_ptr && dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " integer, intent(in) :: %s", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_code); - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - fortprintf(fd, "\n"); - - fclose(fd); - - /* - * Generate dummy dimension argument declaration list - */ - fd = fopen("dim_dummy_decls_inout.inc", "w"); - dim_ptr = dims; - if (dim_ptr && dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " integer, intent(inout) :: %s", dim_ptr->name_in_code); - dim_ptr = dim_ptr->next; - } - else if (dim_ptr && dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " integer, intent(inout) :: %s", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_code); - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - fortprintf(fd, "\n"); - - fclose(fd); - - /* - * Generate non-input dummy dimension argument declaration list - */ - fd = fopen("dim_dummy_decls_noinput.inc", "w"); - dim_ptr = dims; - if (dim_ptr && dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " integer :: %s", dim_ptr->name_in_code); - dim_ptr = dim_ptr->next; - } - else if (dim_ptr && dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " integer :: %s", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_code); - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, ", %s", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - fortprintf(fd, "\n"); - - fclose(fd); - - - - /* - * Generate dummy dimension assignment instructions - */ - fd = fopen("dim_dummy_assigns.inc", "w"); - dim_ptr = dims; - if (dim_ptr && dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " %s = block %% mesh %% %s\n", dim_ptr->name_in_code, dim_ptr->name_in_code); - dim_ptr = dim_ptr->next; - } - else if (dim_ptr && dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) { - fortprintf(fd, " %s = block %% mesh %% %s\n", dim_ptr->name_in_file, dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s = block %% mesh %% %s\n", dim_ptr->name_in_code, dim_ptr->name_in_code); - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s = block %% mesh %% %s\n", dim_ptr->name_in_file, dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - fortprintf(fd, "\n"); - - fclose(fd); - - - /* - * Generate declarations of dimensions - */ - fd = fopen("dim_decls.inc", "w"); - dim_ptr = dims; - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %s\n", dim_ptr->name_in_code); - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " integer :: %s\n", dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - - fclose(fd); - - - /* - * Generate calls to read dimensions from input file - */ - fd = fopen("read_dims.inc", "w"); - dim_ptr = dims; - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " call MPAS_io_inq_dim(inputHandle, \'%s\', %s, ierr)\n", dim_ptr->name_in_file, dim_ptr->name_in_code); - else if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s = %s\n", dim_ptr->name_in_file, dim_ptr->name_in_code); - dim_ptr = dim_ptr->next; - } - - fclose(fd); - - - /* - * Generate declarations of mesh group - */ - fd = fopen("time_invariant_fields.inc", "w"); - group_ptr = groups; - while (group_ptr) { - - if (!strncmp(group_ptr->name, "mesh", 1024)) { - - var_list_ptr = group_ptr->vlist; - memcpy(var_array, var_list_ptr->var->var_array, 1024); - i = 1; - while (var_list_ptr) { - if (strncmp(var_array, var_list_ptr->var->var_array, 1024) != 0) { - memcpy(var_array, var_list_ptr->var->var_array, 1024); - i = 1; - } - if (strncmp(var_list_ptr->var->array_class, "-", 1024) != 0) fortprintf(fd, " integer :: index_%s = -1\n", var_list_ptr->var->name_in_code); - var_list_ptr = var_list_ptr->next; - } - - var_list_ptr = group_ptr->vlist; - memcpy(var_array, var_list_ptr->var->var_array, 1024); - memcpy(array_class, var_list_ptr->var->array_class, 1024); - class_start = 1; - class_end = 1; - i = 1; - while (var_list_ptr) { - if (strncmp(var_list_ptr->var->var_array, "-", 1024) != 0) { - if (strncmp(var_array, var_list_ptr->var->var_array, 1024) != 0) { - if (strncmp(var_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = -1\n", array_class); - if (strncmp(var_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = -1\n", var_array); - class_start = 1; - class_end = 1; - i = 1; - memcpy(var_array, var_list_ptr->var->var_array, 1024); - memcpy(array_class, var_list_ptr->var->array_class, 1024); - fortprintf(fd, " integer :: %s_start = -1\n", array_class); - } - else if (strncmp(array_class, var_list_ptr->var->array_class, 1024) != 0) { - fortprintf(fd, " integer :: %s_end = -1\n", array_class); - class_start = class_end+1; - class_end = class_start; - memcpy(array_class, var_list_ptr->var->array_class, 1024); - fortprintf(fd, " integer :: %s_start = -1\n", array_class); - i++; - } - else { - class_end++; - i++; - } - } - var_list_ptr = var_list_ptr->next; - } - if (strncmp(var_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = -1\n", array_class); - if (strncmp(var_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = -1\n", var_array); - - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - if (!strncmp(var_ptr->var_array, "-", 1024)) { - if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s\n", var_ptr->ndims, var_ptr->name_in_code); - if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s\n", var_ptr->ndims, var_ptr->name_in_code); - if (var_ptr->vtype == CHARACTER) fortprintf(fd, " type (field%idChar), pointer :: %s\n", var_ptr->ndims, var_ptr->name_in_code); - } - else { - if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s\n", var_ptr->ndims+1, var_ptr->var_array); - if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s\n", var_ptr->ndims+1, var_ptr->var_array); - if (var_ptr->vtype == CHARACTER) fortprintf(fd, " type (field%idChar), pointer :: %s\n", var_ptr->ndims+1, var_ptr->var_array); - while (var_list_ptr->next && !strncmp(var_list_ptr->next->var->var_array, var_list_ptr->var->var_array, 1024)) var_list_ptr = var_list_ptr->next; - } - var_list_ptr = var_list_ptr->next; - } - break; - } - group_ptr = group_ptr->next; - } - - fclose(fd); - - - /* - * Generate declarations of non-mesh groups - */ - fd = fopen("variable_groups.inc", "w"); - - group_ptr = groups; - while (group_ptr) { - if (strncmp(group_ptr->name, "mesh", 1024)) { - fortprintf(fd, " type %s_type\n", group_ptr->name); - - fortprintf(fd, " type (block_type), pointer :: block\n"); - - var_list_ptr = group_ptr->vlist; - if(group_ptr->vlist != NULL){ - memcpy(var_array, var_list_ptr->var->var_array, 1024); - i = 1; - while (var_list_ptr) { - if (strncmp(var_array, var_list_ptr->var->var_array, 1024) != 0) { - memcpy(var_array, var_list_ptr->var->var_array, 1024); - i = 1; - } - if (strncmp(var_list_ptr->var->array_class, "-", 1024) != 0) fortprintf(fd, " integer :: index_%s = -1\n", var_list_ptr->var->name_in_code); - var_list_ptr = var_list_ptr->next; - } - - var_list_ptr = group_ptr->vlist; - sprintf(var_array, "-"); - sprintf(array_class, "-"); - class_start = 1; - class_end = 1; - i = 1; - - while (var_list_ptr) { - - /* Is the current variable in a super array? */ - if (strncmp(var_list_ptr->var->var_array, "-", 1024) != 0) { - - /* Have we hit the beginning of a new super array? */ - if (strncmp(var_array, var_list_ptr->var->var_array, 1024) != 0) { - /* Finish off the previous super array? */ - if (strncmp(var_array, "-", 1024) != 0) { - fortprintf(fd, " integer :: %s_end = -1\n", array_class); - fortprintf(fd, " integer :: num_%s = -1\n", var_array); - } - class_start = 1; - class_end = 1; - i = 1; - memcpy(var_array, var_list_ptr->var->var_array, 1024); - memcpy(array_class, var_list_ptr->var->array_class, 1024); - fortprintf(fd, " integer :: %s_start = -1\n", array_class); - } - /* Or have we hit the beginning of a new array class? */ - else if (strncmp(array_class, var_list_ptr->var->array_class, 1024) != 0) { - fortprintf(fd, " integer :: %s_end = -1\n", array_class); - class_start = class_end+1; - class_end = class_start; - memcpy(array_class, var_list_ptr->var->array_class, 1024); - fortprintf(fd, " integer :: %s_start = -1\n", array_class); - i++; - } - else { - class_end++; - i++; - } - - } - var_list_ptr = var_list_ptr->next; - - } - if (strncmp(var_array, "-", 1024) != 0) fortprintf(fd, " integer :: %s_end = -1\n", array_class); - if (strncmp(var_array, "-", 1024) != 0) fortprintf(fd, " integer :: num_%s = -1\n", var_array); - - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - if (!strncmp(var_ptr->var_array, "-", 1024)) { - if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s\n", var_ptr->ndims, var_ptr->name_in_code); - if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s\n", var_ptr->ndims, var_ptr->name_in_code); - if (var_ptr->vtype == CHARACTER) fortprintf(fd, " type (field%idChar), pointer :: %s\n", var_ptr->ndims, var_ptr->name_in_code); - } - else { - if (var_ptr->vtype == INTEGER) fortprintf(fd, " type (field%idInteger), pointer :: %s\n", var_ptr->ndims+1, var_ptr->var_array); - if (var_ptr->vtype == REAL) fortprintf(fd, " type (field%idReal), pointer :: %s\n", var_ptr->ndims+1, var_ptr->var_array); - if (var_ptr->vtype == CHARACTER) fortprintf(fd, " type (field%idChar), pointer :: %s\n", var_ptr->ndims+1, var_ptr->var_array); - while (var_list_ptr->next && !strncmp(var_list_ptr->next->var->var_array, var_list_ptr->var->var_array, 1024)) var_list_ptr = var_list_ptr->next; - } - var_list_ptr = var_list_ptr->next; - } - } - - fortprintf(fd, " end type %s_type\n\n\n", group_ptr->name); - - if (group_ptr->ntime_levs > 1) { - fortprintf(fd, " type %s_pointer_type\n", group_ptr->name); - fortprintf(fd, " type (%s_type), pointer :: %s \n", group_ptr->name, group_ptr->name); - fortprintf(fd, " end type %s_pointer_type\n\n\n", group_ptr->name); - - fortprintf(fd, " type %s_multilevel_type\n", group_ptr->name); - fortprintf(fd, " integer :: nTimeLevels\n"); - fortprintf(fd, " type (%s_pointer_type), dimension(:), pointer :: time_levs\n", group_ptr->name); - fortprintf(fd, " end type %s_multilevel_type\n\n\n", group_ptr->name); - } - } - group_ptr = group_ptr->next; - } - - fclose(fd); - - /* - * Generate instantiations of variable groups in block_type - */ - fd = fopen("block_group_members.inc", "w"); - - group_ptr = groups; - while (group_ptr) { - if (group_ptr->ntime_levs > 1) { - fortprintf(fd, " type (%s_multilevel_type), pointer :: %s\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " type (%s_type), pointer :: provis_%s\n", group_ptr->name, group_ptr->name); - } else { - fortprintf(fd, " type (%s_type), pointer :: %s\n", group_ptr->name, group_ptr->name); - } - group_ptr = group_ptr->next; - } - - fclose(fd); - - - /* - * Generate routines for allocating provisional types - */ - fd = fopen("provis_alloc_routines.inc", "w"); - - group_ptr = groups; - while (group_ptr) { - if (group_ptr->ntime_levs > 1) { - fortprintf(fd, " subroutine mpas_setup_provis_%s(b)!{{{\n", group_ptr->name); - fortprintf(fd, " type (block_type), pointer :: b\n"); - fortprintf(fd, " type (block_type), pointer :: block\n\n"); - fortprintf(fd, "#include \"dim_dummy_decls_noinput.inc\"\n\n"); - fortprintf(fd, " block => b\n"); - fortprintf(fd, " do while(associated(block))\n"); - fortprintf(fd, "#include \"dim_dummy_assigns.inc\"\n\n"); - fortprintf(fd, " allocate(block %% provis_%s)\n", group_ptr->name); - fortprintf(fd, " call mpas_allocate_%s(block, block %% provis_%s, &\n", group_ptr->name, group_ptr->name); - fortprintf(fd, "#include \"dim_dummy_args.inc\"\n"); - fortprintf(fd, " )\n\n"); - fortprintf(fd, " block => block %% next \n"); - fortprintf(fd, " end do\n\n"); - fortprintf(fd, " block => b\n"); - fortprintf(fd, " do while(associated(block))\n"); - fortprintf(fd, " if(associated(block %% prev) .and. associated(block %% next)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(block %% provis_%s, prev = block %% prev %% provis_%s, next = block %% next %% provis_%s)\n", group_ptr->name, group_ptr->name, group_ptr->name, group_ptr->name); - fortprintf(fd, " else if(associated(block %% prev)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(block %% provis_%s, prev = block %% prev %% provis_%s)\n", group_ptr->name, group_ptr->name, group_ptr->name); - fortprintf(fd, " else if(associated(block %% next)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(block %% provis_%s, next = block %% next %% provis_%s)\n", group_ptr->name, group_ptr->name, group_ptr->name); - fortprintf(fd, " else\n"); - fortprintf(fd, " call mpas_create_%s_links(block %% provis_%s)\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " end if\n"); - fortprintf(fd, " block => block %% next \n"); - fortprintf(fd, " end do\n"); - fortprintf(fd, " end subroutine mpas_setup_provis_%s!}}}\n\n", group_ptr->name); - - fortprintf(fd, " subroutine mpas_deallocate_provis_%s(b)!{{{\n", group_ptr->name); - fortprintf(fd, " type (block_type), pointer :: b\n"); - fortprintf(fd, " type (block_type), pointer :: block\n\n"); - fortprintf(fd, " block => b\n"); - fortprintf(fd, " do while(associated(block))\n"); - fortprintf(fd, " call mpas_deallocate_%s(block %% provis_%s)\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " deallocate(block %% provis_%s)\n", group_ptr->name); - fortprintf(fd, " block => block %% next\n"); - fortprintf(fd, " end do\n"); - fortprintf(fd, " end subroutine mpas_deallocate_provis_%s!}}}\n", group_ptr->name); - } - group_ptr = group_ptr->next; - } - fclose(fd); - - - - /* To be included in allocate_block */ - fd = fopen("block_allocs.inc", "w"); - group_ptr = groups; - while (group_ptr) { - fortprintf(fd, " allocate(b %% %s)\n", group_ptr->name); - if (group_ptr->ntime_levs > 1) { - fortprintf(fd, " b %% %s %% nTimeLevels = %i\n", group_ptr->name, group_ptr->ntime_levs); - fortprintf(fd, " allocate(b %% %s %% time_levs(%i))\n", group_ptr->name, group_ptr->ntime_levs); - fortprintf(fd, " do i=1,b %% %s %% nTimeLevels\n", group_ptr->name); - fortprintf(fd, " allocate(b %% %s %% time_levs(i) %% %s)\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " call mpas_allocate_%s(b, b %% %s %% time_levs(i) %% %s, &\n", group_ptr->name, group_ptr->name, group_ptr->name); - fortprintf(fd, "#include \"dim_dummy_args.inc\"\n"); - fortprintf(fd, " )\n"); - fortprintf(fd, " end do\n\n"); - } - else { - fortprintf(fd, " call mpas_allocate_%s(b, b %% %s, &\n", group_ptr->name, group_ptr->name); - fortprintf(fd, "#include \"dim_dummy_args.inc\"\n"); - fortprintf(fd, " )\n\n"); - } - group_ptr = group_ptr->next; - } - fclose(fd); - - - /* To be included in deallocate_block */ - fd = fopen("block_deallocs.inc", "w"); - group_ptr = groups; - while (group_ptr) { - if (group_ptr->ntime_levs > 1) { - fortprintf(fd, " do i=1,b %% %s %% nTimeLevels\n", group_ptr->name); - fortprintf(fd, " call mpas_deallocate_%s(b %% %s %% time_levs(i) %% %s)\n", group_ptr->name, group_ptr->name, group_ptr->name); - fortprintf(fd, " deallocate(b %% %s %% time_levs(i) %% %s)\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " end do\n"); - fortprintf(fd, " deallocate(b %% %s %% time_levs)\n", group_ptr->name); - } - else { - fortprintf(fd, " call mpas_deallocate_%s(b %% %s)\n", group_ptr->name, group_ptr->name); - } - fortprintf(fd, " deallocate(b %% %s)\n\n", group_ptr->name); - group_ptr = group_ptr->next; - } - fclose(fd); - - /* Definitions of allocate subroutines */ - fd = fopen("group_alloc_routines.inc", "w"); - group_ptr = groups; - while (group_ptr) { - fortprintf(fd, " subroutine mpas_allocate_%s(b, %s, &\n", group_ptr->name, group_ptr->name); - fortprintf(fd, "#include \"dim_dummy_args.inc\"\n"); - fortprintf(fd, " )\n"); - fortprintf(fd, "\n"); - fortprintf(fd, " implicit none\n"); - fortprintf(fd, "\n"); - fortprintf(fd, " type (block_type), pointer :: b\n"); - fortprintf(fd, " type (%s_type), intent(inout) :: %s\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " logical :: group_started\n"); - fortprintf(fd, " integer :: index_counter\n"); - fortprintf(fd, " integer :: group_counter\n"); - fortprintf(fd, " integer :: group_start\n"); - fortprintf(fd, "#include \"dim_dummy_decls.inc\"\n"); - fortprintf(fd, "\n"); - - fortprintf(fd, " %s %% block => b\n", group_ptr->name); - - if (!strncmp(group_ptr->name, "mesh", 1024)) { - dim_ptr = dims; - while (dim_ptr) { - if (dim_ptr->constant_value < 0 && !dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s %% %s = %s\n", group_ptr->name, dim_ptr->name_in_code, dim_ptr->name_in_code); - if (dim_ptr->constant_value < 0 && dim_ptr->namelist_defined && !is_derived_dim(dim_ptr->name_in_code)) fortprintf(fd, " %s %% %s = %s\n", group_ptr->name, dim_ptr->name_in_file, dim_ptr->name_in_file); - dim_ptr = dim_ptr->next; - } - - fortprintf(fd, "\n"); - } - - - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - if (strncmp(var_ptr->var_array, "-", 1024) != 0) { - memcpy(var_array, var_ptr->var_array, 1024); - memcpy(array_class, var_ptr->array_class, 1024); - i = 0; - while (var_list_ptr && strncmp(var_array, var_list_ptr->var->var_array, 1024) == 0) { - i++; - var_list_ptr2 = var_list_ptr; - var_list_ptr = var_list_ptr->next; - } - var_ptr2 = var_list_ptr2->var; - fortprintf(fd, " index_counter = 0\n"); - fortprintf(fd, " group_counter = -1\n"); - fortprintf(fd, " group_start = -1\n"); - fortprintf(fd, " group_started = .false.\n"); - fortprintf(fd, " allocate(%s %% %s)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " allocate(%s %% %s %% ioinfo)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% fieldName = \'%s\'\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% isVarArray = .true.\n", group_ptr->name, var_ptr2->var_array); - /* Initialization of indices and size */ - i = 0; - new_class = 0; - var_list_ptr3 = group_ptr->vlist; - memcpy(array_class, "-", 1024); - while (var_list_ptr3) { - if (strncmp(var_array, var_list_ptr3->var->var_array, 1024) == 0) { - if (strncmp(array_class, var_list_ptr3->var->array_class, 1024) != 0) { - if (strncmp(array_class, "-", 1024) != 0) { - fortprintf(fd, " if (group_counter >= 0) then\n"); - fortprintf(fd, " %s %% %s_start = group_start\n", group_ptr->name, array_class); - fortprintf(fd, " %s %% %s_end = group_start + group_counter\n", group_ptr->name, array_class); - fortprintf(fd, " end if\n"); - fortprintf(fd, " group_counter = -1\n"); - fortprintf(fd, " group_started = .false.\n"); - } - memcpy(array_class, var_list_ptr3->var->array_class, 1024); - } - - if(var_list_ptr3->var->persistence != PACKAGE){ - fortprintf(fd, " index_counter = index_counter + 1\n"); - fortprintf(fd, " group_counter = group_counter + 1\n"); - fortprintf(fd, " %s %% index_%s = index_counter\n", group_ptr->name, var_list_ptr3->var->name_in_code); - fortprintf(fd, " if (.not. group_started) then\n"); - fortprintf(fd, " group_start = index_counter\n"); - fortprintf(fd, " group_started = .true.\n"); - fortprintf(fd, " end if\n"); - } else { - fortprintf(fd, " if ("); - write_package_options(fd, var_list_ptr3->var->package_name); - fortprintf(fd, ") then\n"); - - fortprintf(fd, " index_counter = index_counter + 1\n"); - fortprintf(fd, " group_counter = group_counter + 1\n"); - fortprintf(fd, " %s %% index_%s = index_counter\n", group_ptr->name, var_list_ptr3->var->name_in_code); - fortprintf(fd, " if (.not. group_started) then\n"); - fortprintf(fd, " group_start = index_counter\n"); - fortprintf(fd, " group_started = .true.\n"); - fortprintf(fd, " end if\n"); - fortprintf(fd, " end if\n"); - } - } - var_list_ptr3 = var_list_ptr3->next; - } - - fortprintf(fd, " if (group_counter > 0) then\n"); - fortprintf(fd, " %s %% %s_start = group_start\n", group_ptr->name, array_class); - fortprintf(fd, " %s %% %s_end = group_start + group_counter\n", group_ptr->name, array_class); - fortprintf(fd, " end if\n"); - fortprintf(fd, " %s %% num_%s = index_counter\n", group_ptr->name, var_array); - fortprintf(fd, " if ( %s %% num_%s > 0 ) then\n", group_ptr->name, var_array); - fortprintf(fd, " allocate(%s %% %s %% constituentNames(%s %% num_%s))\n", group_ptr->name, var_array, group_ptr->name, var_array); - fortprintf(fd, " end if\n"); + ezxml_t nmlrecs_xml, nmlopt_xml; + + const char *const_core; + const char *nmlrecname, *nmlrecindef, *nmlrecinsub; + const char *nmloptname, *nmlopttype, *nmloptval, *nmloptunits, *nmloptdesc, *nmloptposvals, *nmloptindef; + + char pool_name[1024]; + char core_string[1024]; + + int in_subpool; + + FILE *fd, *fd2; + + const_core = ezxml_attr(registry, "core"); + + sprintf(core_string, "_%s_", const_core); + + // For now, don't include core name in subroutines + sprintf(core_string, "_"); + + fd = fopen("namelist_defines.inc", "w+"); + fd2 = fopen("namelist_call.inc", "w+"); + + fortprintf(fd2, " subroutine mpas_setup_namelists(configPool, namelistFilename, dminfo)\n"); + fortprintf(fd2, " type (mpas_pool_type), intent(inout) :: configPool\n"); + fortprintf(fd2, " character (len=*), intent(in) :: namelistFilename\n"); + fortprintf(fd2, " type (dm_info), intent(in) :: dminfo\n"); + fortprintf(fd2, "\n"); + fortprintf(fd2, " integer :: unitNumber\n"); + fortprintf(fd2, "\n"); + fortprintf(fd2, " unitNumber = 21\n"); + fortprintf(fd2, " open(unitNumber,file=trim(namelistFilename),status='old',form='formatted')\n"); + fortprintf(fd2, "\n"); + + + // Parse Namelist Records + for (nmlrecs_xml = ezxml_child(registry, "nml_record"); nmlrecs_xml; nmlrecs_xml = nmlrecs_xml->next){ + nmlrecname = ezxml_attr(nmlrecs_xml, "name"); + nmlrecindef = ezxml_attr(nmlrecs_xml, "in_defaults"); + nmlrecinsub = ezxml_attr(nmlrecs_xml, "in_subpool"); + + in_subpool = 0; + + if(nmlrecinsub){ + if(strcmp(nmlrecinsub, "true") == 0){ + in_subpool = 1; + } + } + + if(in_subpool){ + sprintf(pool_name, "recordPool"); + } else { + sprintf(pool_name, "configPool"); + } + + // Add call to driver routine. + fortprintf(fd2, " call mpas_setup%snmlrec_%s(configPool, unitNumber, dminfo)\n", core_string, nmlrecname); + + // Start defining new subroutine for namelist record. + fortprintf(fd, " subroutine mpas_setup%snmlrec_%s(configPool, unitNumber, dminfo)\n", core_string, nmlrecname); + fortprintf(fd, " type (mpas_pool_type), intent(inout) :: configPool\n"); + fortprintf(fd, " integer, intent(in) :: unitNumber\n"); + fortprintf(fd, " type (dm_info), intent(in) :: dminfo\n"); + fortprintf(fd, "\n"); + fortprintf(fd, " integer :: ierr\n"); + fortprintf(fd, " type (mpas_pool_type), pointer :: recordPool\n"); + fortprintf(fd, "\n"); + + // Define variable defintions prior to reading the namelist in. + for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ + nmloptname = ezxml_attr(nmlopt_xml, "name"); + nmlopttype = ezxml_attr(nmlopt_xml, "type"); + nmloptval = ezxml_attr(nmlopt_xml, "default_value"); + nmloptunits = ezxml_attr(nmlopt_xml, "units"); + nmloptdesc = ezxml_attr(nmlopt_xml, "description"); + nmloptposvals = ezxml_attr(nmlopt_xml, "possible_values"); + nmloptindef = ezxml_attr(nmlopt_xml, "in_defaults"); + + if(strncmp(nmlopttype, "real", 1024) == 0){ + fortprintf(fd, " real (kind=RKIND) :: %s = %lf\n", nmloptname, (float)atof(nmloptval)); + } else if(strncmp(nmlopttype, "integer", 1024) == 0){ + fortprintf(fd, " integer :: %s = %d\n", nmloptname, atoi(nmloptval)); + } else if(strncmp(nmlopttype, "logical", 1024) == 0){ + if(strncmp(nmloptval, "true", 1024) == 0 || strncmp(nmloptval, ".true.", 1024) == 0){ + fortprintf(fd, " logical :: %s = .true.\n", nmloptname); + } else { + fortprintf(fd, " logical :: %s = .false.\n", nmloptname); + } + } else if(strncmp(nmlopttype, "character", 1024) == 0){ + fortprintf(fd, " character (len=StrKIND) :: %s = '%s'\n", nmloptname, nmloptval); + } + } + fortprintf(fd, "\n"); + + // Define the namelist block, to read the namelist record in. + fortprintf(fd, " namelist /%s/ &\n", nmlrecname); + for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ + nmloptname = ezxml_attr(nmlopt_xml, "name"); + if(nmlopt_xml->next){ + fortprintf(fd, " %s, &\n", nmloptname); + } else { + fortprintf(fd, " %s\n", nmloptname); + } + } + + if(in_subpool){ + fortprintf(fd, "\n"); + fortprintf(fd, " allocate(recordPool)\n"); + fortprintf(fd, " call mpas_pool_create_pool(recordPool)\n"); + fortprintf(fd, " call mpas_pool_add_subpool(configPool, '%s', recordPool)\n", nmlrecname); + fortprintf(fd, "\n"); + } + + fortprintf(fd, " if (dminfo %% my_proc_id == IO_NODE) then\n"); + fortprintf(fd, " rewind(unitNumber)\n"); + fortprintf(fd, " read(unitNumber, %s, iostat=ierr)\n", nmlrecname); + fortprintf(fd, " if (ierr > 0) then\n"); + fortprintf(fd, " write(stderrUnit, *) 'Error while reading namelist record %s.'\n", nmlrecname); + fortprintf(fd, " call mpas_dmpar_abort(dminfo)\n"); + fortprintf(fd, " else if (ierr < 0) then\n"); + fortprintf(fd, " write(stderrUnit,*) 'Namelist record %s not found; using default values for variables in this namelist'\n", nmlrecname); + fortprintf(fd, " end if\n"); + fortprintf(fd, " end if\n"); + + // Broadcast ierr, to check if a broadcast should happen for the options (if namelist was read in) + fortprintf(fd, " call mpas_dmpar_bcast_int(dminfo, ierr)\n"); + + fortprintf(fd, "\n"); + // Define broadcast calls for namelist values. + fortprintf(fd, " if (ierr == 0) then\n"); + for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ + nmloptname = ezxml_attr(nmlopt_xml, "name"); + nmlopttype = ezxml_attr(nmlopt_xml, "type"); + + if(strncmp(nmlopttype, "real", 1024) == 0){ + fortprintf(fd, " call mpas_dmpar_bcast_real(dminfo, %s)\n", nmloptname); + } else if(strncmp(nmlopttype, "integer", 1024) == 0){ + fortprintf(fd, " call mpas_dmpar_bcast_int(dminfo, %s)\n", nmloptname); + } else if(strncmp(nmlopttype, "logical", 1024) == 0){ + fortprintf(fd, " call mpas_dmpar_bcast_logical(dminfo, %s)\n", nmloptname); + } else if(strncmp(nmlopttype, "character", 1024) == 0){ + fortprintf(fd, " call mpas_dmpar_bcast_char(dminfo, %s)\n", nmloptname); + } + } + fortprintf(fd, " end if\n"); + fortprintf(fd, "\n"); + + for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ + nmloptname = ezxml_attr(nmlopt_xml, "name"); + + fortprintf(fd, " call mpas_pool_add_config(%s, '%s', %s)\n", pool_name, nmloptname, nmloptname); + } + fortprintf(fd, "\n"); + + // End new subroutine for namelist record. + fortprintf(fd, " end subroutine mpas_setup%snmlrec_%s\n", core_string, nmlrecname); + fortprintf(fd, "\n\n"); + } + + fortprintf(fd2, "\n"); + fortprintf(fd2, " close(unitNumber)\n"); + fortprintf(fd2, " end subroutine mpas_setup_namelists\n"); + + return 0; +}/*}}}*/ + + +int parse_dimensions_from_registry(ezxml_t registry)/*{{{*/ +{ + ezxml_t dims_xml, dim_xml; + ezxml_t nmlrec_xml, nmlopt_xml; + + const char *nmlrecname, *nmlrecinsub, *nmloptname, *nmlopttype; + const char *dimname, *dimunits, *dimdesc, *dimdef; + const char *corename; + + char option_name[1024]; + char core_string[1024]; + char dim_args[2048]; + + FILE *fd, *fd2, *fd3, *fd4, *fd5, *fd6; + + int in_subpool; + + corename = ezxml_attr(registry, "core"); + + sprintf(core_string, "_%s_", corename); + + // For now, don't include core name in subroutines + sprintf(core_string, "_"); + + // Open files + fd = fopen("read_dimensions.inc", "w+"); + fd2 = fopen("dim_dummy_args.inc", "w+"); + fd3 = fopen("add_dims_to_pool.inc", "w+"); + fd4 = fopen("dim_dummy_defines_input.inc", "w+"); + fd5 = fopen("dim_dummy_defines_noinput.inc", "w+"); + fd6 = fopen("dim_dummy_defines_inout.inc", "w+"); + + dim_args[0] = '\0'; + + // Parse dimensions that need to be read in + for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ + for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ + dimname = ezxml_attr(dim_xml, "name"); + dimdef = ezxml_attr(dim_xml, "definition"); + + // Only dimensions that don't have a definition + if(dimdef == NULL){ + // Write the read_dimension file, which reads dimensions from the input file + fortprintf(fd, " call mpas_io_inq_dim(inputHandle, '%s', %s, ierr)\n", dimname, dimname); + + // Write the dim dummy args list, which defines the argument list for subroutines that pass dimensions. + if(strlen(dim_args) <= 1){ + sprintf(dim_args, "%s", dimname); + } else { + sprintf(dim_args, "%s, %s", dim_args, dimname); + } + + + fortprintf(fd3, " call mpas_pool_add_dimension(block_ptr %% dimensions, '%s', %s)\n", dimname, dimname); - /* Initialization for constituent names */ - i = 0; - var_list_ptr3 = group_ptr->vlist; - while (var_list_ptr3) { - if (strncmp(var_array, var_list_ptr3->var->var_array, 1024) == 0) { - if(var_list_ptr3->var->persistence != PACKAGE) { - fortprintf(fd, " %s %% %s %% constituentNames(%s %% index_%s) = \'%s\'\n", group_ptr->name, var_array, group_ptr->name, var_list_ptr3->var->name_in_code, var_list_ptr3->var->name_in_file); - } else { - fortprintf(fd, " if (%s %% index_%s > 0) then\n", group_ptr->name, var_list_ptr3->var->name_in_code); - fortprintf(fd, " %s %% %s %% constituentNames(%s %% index_%s) = \'%s\'\n", group_ptr->name, var_array, group_ptr->name, var_list_ptr3->var->name_in_code, var_list_ptr3->var->name_in_file); - fortprintf(fd, " end if\n"); - - } - } - var_list_ptr3 = var_list_ptr3->next; - } - - if(var_ptr2->persistence == PERSISTENT || var_ptr2->persistence == PACKAGE){ - fortprintf(fd, " %s %% %s %% isPersistent = .true.\n", group_ptr->name, var_ptr2->var_array); - if(var_ptr2->persistence == PACKAGE){ - fortprintf(fd, " if (%s %% num_%s > 0) then\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% isActive = .true.\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " allocate(%s %% %s %% array(%s %% num_%s, ", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - } else { - fortprintf(fd, " %s %% %s %% isActive = .true.\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " allocate(%s %% %s %% array(%s %% num_%s, ", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - } - 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 (!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, "))\n"); - if (var_ptr2->persistence == PACKAGE) { - fortprintf(fd, " %s %% %s %% array = %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->default_value ); /* initialize field */ - fortprintf(fd, " else\n"); - fortprintf(fd, " %s %% %s %% isActive = .false.\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " nullify(%s %% %s %% array)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n"); - } else { - fortprintf(fd, " %s %% %s %% array = %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->default_value ); /* initialize field */ - } + // Write the dim dummy defines files, which defines the dimension within a subroutine. + fortprintf(fd4, " integer, intent(in) :: %s\n", dimname); + fortprintf(fd5, " integer :: %s\n", dimname); + fortprintf(fd6, " integer, intent(inout) :: %s\n", dimname); + + } + } + } + + fortprintf(fd2, "%s &\n", dim_args); + + // Close files + fclose(fd); + fclose(fd2); + fclose(fd3); + fclose(fd4); + fclose(fd5); + fclose(fd6); + + // Write subroutine to defined derived dimensions + fd = fopen("define_dimensions.inc", "w+"); + fortprintf(fd, " subroutine mpas_define%sderived_dimensions(dimensionPool, configPool)\n", core_string); + fortprintf(fd, " type (mpas_pool_type), intent(inout) :: dimensionPool\n"); + fortprintf(fd, " type (mpas_pool_type), intent(inout) :: configPool\n"); + fortprintf(fd, "\n"); + + // Define all dimensions + for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ + for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ + dimname = ezxml_attr(dim_xml, "name"); + dimdef = ezxml_attr(dim_xml, "definition"); + + fortprintf(fd, " integer, pointer :: %s\n", dimname); + + if(dimdef != NULL){ + // Namelist defined dimension + if(strncmp(dimdef, "namelist:", 9) == 0){ + snprintf(option_name, 1024, "%s", (dimdef)+9); + // Need to define a variable to hold the namelist value + // First need to find the registry defined namlist option, so we can determine type: + for (nmlrec_xml = ezxml_child(registry, "nml_record"); nmlrec_xml; nmlrec_xml = nmlrec_xml->next){ + nmlrecname = ezxml_attr(nmlrec_xml, "name"); + for (nmlopt_xml = ezxml_child(nmlrec_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ + nmloptname = ezxml_attr(nmlopt_xml, "name"); + nmlopttype = ezxml_attr(nmlopt_xml, "type"); + + if(strncmp(option_name, nmloptname, 1024) == 0){ + if(strncmp(nmlopttype, "real", 1024) == 0){ + fortprintf(fd, " real (kind=RKIND), pointer :: %s\n", nmloptname); + } else if(strncmp(nmlopttype, "integer", 1024) == 0){ + fortprintf(fd, " integer, pointer :: %s\n", nmloptname); + } else if(strncmp(nmlopttype, "logical", 1024) == 0){ + fortprintf(fd, " logical, pointer :: %s\n", nmloptname); + } else if(strncmp(nmlopttype, "character", 1024) == 0){ + fortprintf(fd, " character (len=StrKIND), pointer :: %s\n", nmloptname); + } + } + } + } + } + } + } + } + + fortprintf(fd,"\n"); + + // Get values of all read in dimensions from pool + // And config options from namelist defined dimensions. + for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ + for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ + dimname = ezxml_attr(dim_xml, "name"); + dimdef = ezxml_attr(dim_xml, "definition"); + + if(dimdef == NULL){ + fortprintf(fd, " call mpas_pool_get_dimension(dimensionPool, '%s', %s)\n", dimname, dimname); } else { - fortprintf(fd, " %s %% %s %% isPersistent = .false.\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% isActive = .false.\n", group_ptr->name, var_ptr2->var_array); + // Namelist defined dimension + if(strncmp(dimdef, "namelist:", 9) == 0){ + snprintf(option_name, 1024, "%s", (dimdef)+9); + // Need to define a variable to hold the namelist value + // First need to find the registry defined namlist option, so we can determine type: + for (nmlrec_xml = ezxml_child(registry, "nml_record"); nmlrec_xml; nmlrec_xml = nmlrec_xml->next){ + nmlrecname = ezxml_attr(nmlrec_xml, "name"); + nmlrecinsub = ezxml_attr(nmlrec_xml, "in_subpool"); + + in_subpool = 0; + + if(nmlrecinsub && strcmp(nmlrecinsub, "true") == 0){ + in_subpool = 1; + } + + for (nmlopt_xml = ezxml_child(nmlrec_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ + nmloptname = ezxml_attr(nmlopt_xml, "name"); + if(strcmp(option_name, nmloptname) == 0){ + if(in_subpool){ + fortprintf(fd, " call mpas_pool_get_config(configPool, '%s', %s, '%s')\n", nmloptname, nmloptname, nmlrecname); + } else { + fortprintf(fd, " call mpas_pool_get_config(configPool, '%s', %s)\n", nmloptname, nmloptname); + } + } + } + } + } + } + } + } + + fortprintf(fd,"\n"); + + // Define and add dimensions to pool + for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ + for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ + dimname = ezxml_attr(dim_xml, "name"); + dimdef = ezxml_attr(dim_xml, "definition"); + + if(dimdef != NULL){ + fortprintf(fd, " allocate(%s)\n", dimname); + // Namelist defined dimension + if(strncmp(dimdef, "namelist:", 9) == 0){ + snprintf(option_name, 1024, "%s", (dimdef)+9); + fortprintf(fd, " %s = %s\n", dimname, option_name); + } else { + fortprintf(fd, " %s = %s\n", dimname, dimdef); + } + + fortprintf(fd, " call mpas_pool_add_dimension(dimensionPool, '%s', %s)\n", dimname, dimname); + } + } + } + fortprintf(fd, "\n"); + fortprintf(fd, " end subroutine mpas_define%sderived_dimensions\n", core_string); + + return 0; +}/*}}}*/ + + +int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t varArray, const char * corename)/*{{{*/ +{ + ezxml_t struct_xml, var_arr_xml, var_xml, var_xml2; + ezxml_t packages_xml, package_xml; + ezxml_t streams_xml, stream_xml, streams_xml2, stream_xml2; + + const char *structname, *structlevs, *structpackages; + const char *substructname; + const char *vararrname, *vararrtype, *vararrdims, *vararrpersistence, *vararrdefaultval, *vararrpackages; + const char *varname, *varpersistence, *vartype, *vardims, *varunits, *vardesc, *vararrgroup, *varstreams, *vardefaultval, *varpackages; + const char *varname2, *vararrgroup2, *vararrname_in_code; + const char *varname_in_code; + const char *streamname, *streamname2; + const char *packagename; + const char *vararrtimelevs; + + int err; + + int iostreams; + int time_lev, time_levs; + int i, skip_var, skip_stream; + int ndims, type, hasTime, decomp, in_stream; + int persistence; + char *string, *tofree, *token; + char pointer_name[1024]; + char spacing[1024], sub_spacing[1024]; + char default_value[1024]; + + structname = ezxml_attr(superStruct, "name"); + + var_arr_xml = varArray; + + // All sub-structs have been parsed and generated at this point. Time to generate this struct + // Start by generating variable arrays + vararrname = ezxml_attr(var_arr_xml, "name"); + vararrtype = ezxml_attr(var_arr_xml, "type"); + vararrdims = ezxml_attr(var_arr_xml, "dimensions"); + vararrpersistence = ezxml_attr(var_arr_xml, "persistence"); + vararrdefaultval = ezxml_attr(var_arr_xml, "default_value"); + vararrpackages = ezxml_attr(var_arr_xml, "packages"); + vararrtimelevs = ezxml_attr(var_arr_xml, "time_levs"); + vararrname_in_code = ezxml_attr(var_arr_xml, "name_in_code"); + + if(!vararrtimelevs){ + vararrtimelevs = ezxml_attr(superStruct, "time_levs"); + } + + if(vararrtimelevs){ + time_levs = atoi(vararrtimelevs); + if(time_levs < 1){ + time_levs = 1; + } + } else { + time_levs = 1; + } + + if(!vararrname_in_code){ + vararrname_in_code = ezxml_attr(var_arr_xml, "name"); + } + + persistence = check_persistence(vararrpersistence); + + fortprintf(fd, "! Define var array %s\n", vararrname); + snprintf(spacing, 1024, " "); + + + // Determine field type and default value. + get_field_information(vararrtype, vararrdefaultval, default_value, &type); + + // Determine ndims, hasTime, and decomp type + get_dimension_information(vararrdims, &ndims, &hasTime, &decomp); + ndims++; // Add a dimension for constituents in var_array + + // Determine name of pointer for this field. + set_pointer_name(type, ndims, pointer_name); + fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + + fortprintf(fd, " index_counter = 0\n", spacing); + fortprintf(fd, " group_counter = -1\n", spacing); + fortprintf(fd, " group_start = -1\n", spacing); + fortprintf(fd, " group_started = .false.\n", spacing); + fortprintf(fd, "\n"); + + // Write index values and group counter values. + // Define each array_group in contiguous sections. + for (var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ + varname = ezxml_attr(var_xml, "name"); + varpackages = ezxml_attr(var_xml, "packages"); + vararrgroup = ezxml_attr(var_xml, "array_group"); + varname_in_code = ezxml_attr(var_xml, "name_in_code"); + skip_var = 0; + + if(!varname_in_code){ + varname_in_code = ezxml_attr(var_xml, "name"); + } + + for (var_xml2 = ezxml_child(var_arr_xml, "var"); var_xml2 && var_xml2 != var_xml; var_xml2 = var_xml2->next){ + // Check if the current array group has already been touched. + vararrgroup2 = ezxml_attr(var_xml2, "array_group"); + + if (strncmp(vararrgroup, vararrgroup2, 1024) == 0){ + skip_var = 1; + } + } + + if(!skip_var){ + + fortprintf(fd, "! Starting group %s\n", vararrgroup); + fortprintf(fd, "! Define constituent var %s\n", varname); + fortprintf(fd, "! My Packages are %s\n", varpackages); + + // If no packages are defined, default to var_arr packages. + if(varpackages == NULL){ + if(vararrpackages != NULL){ + varpackages = ezxml_attr(var_arr_xml, "packages"); + } + } + + // Parse packages if they are defined + sub_spacing[0] = '\0'; + if(varpackages){ + fortprintf(fd, " if ("); + string = strdup(varpackages); + tofree = string; + token = strsep(&string, ";"); + fortprintf(fd, "%sActive", token); + + while( (token = strsep(&string, ";")) != NULL){ + fortprintf(fd, " .or. %sActive", token); + } + + fortprintf(fd, ") then\n"); + snprintf(sub_spacing, 1024, " "); + } + + fortprintf(fd, " %sindex_counter = index_counter + 1\n", sub_spacing); + fortprintf(fd, " %sif (associated(newSubPool)) then\n", sub_spacing); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, 'index_%s', index_counter)\n", sub_spacing, varname_in_code); + fortprintf(fd, " %send if\n", sub_spacing); + fortprintf(fd, " %sgroup_counter = group_counter + 1\n", sub_spacing); + fortprintf(fd, " %sif (.not. group_started) then\n", sub_spacing); + fortprintf(fd, " %s group_start = index_counter\n", sub_spacing); + fortprintf(fd, " %s if (associated(newSubPool)) then\n", sub_spacing); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, '%s_start', group_start)\n", sub_spacing, vararrgroup); + fortprintf(fd, " %s end if\n", sub_spacing); + fortprintf(fd, " %s group_started = .true.\n", sub_spacing); + fortprintf(fd, " %send if\n", sub_spacing); + + // If Packages are defined, write else clause + if(varpackages){ + fortprintf(fd, " %selse\n", sub_spacing); + fortprintf(fd, " %s if (associated(newSubPool)) then\n", sub_spacing); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, 'index_%s', -1)\n", sub_spacing, varname_in_code); + fortprintf(fd, " %s end if\n", sub_spacing); + fortprintf(fd, " %send if\n", sub_spacing); } - fortprintf(fd, " %s %% %s %% dimSizes(1) = %s %% num_%s\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% dimNames(1) = \'num_%s\'\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - dimlist_ptr = var_ptr2->dimlist; - i = 2; - while (dimlist_ptr) { - if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) || - !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) || - !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024)) - if (!dimlist_ptr->dim->namelist_defined) { - if (var_ptr2->persistence == PERSISTENT || var_ptr2->persistence == PACKAGE){ - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_code); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_file); - } - else { - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s+1\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_code); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_file); - } - } - else { - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_file); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_file); - } - else - if (dimlist_ptr->dim->namelist_defined) { - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_file); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_file); - } - else { - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_code); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr2->var_array, i, dimlist_ptr->dim->name_in_file); - } - i++; - dimlist_ptr = dimlist_ptr->next; - } - if (var_ptr2->timedim) fortprintf(fd, " %s %% %s %% hasTimeDimension = .true.\n", group_ptr->name, var_ptr2->var_array); - else fortprintf(fd, " %s %% %s %% hasTimeDimension = .false.\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " nullify(%s %% %s %% sendList)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " nullify(%s %% %s %% recvList)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " nullify(%s %% %s %% copyList)\n", group_ptr->name, var_ptr2->var_array); - - if (var_ptr2->iostreams & INPUT0) - fortprintf(fd, " %s %% %s %% ioinfo %% input = .true.\n", group_ptr->name, var_ptr2->var_array); - else - fortprintf(fd, " %s %% %s %% ioinfo %% input = .false.\n", group_ptr->name, var_ptr2->var_array); - - if (var_ptr2->iostreams & SFC0) - fortprintf(fd, " %s %% %s %% ioinfo %% sfc = .true.\n", group_ptr->name, var_ptr2->var_array); - else - fortprintf(fd, " %s %% %s %% ioinfo %% sfc = .false.\n", group_ptr->name, var_ptr2->var_array); - - if (var_ptr2->iostreams & RESTART0) - fortprintf(fd, " %s %% %s %% ioinfo %% restart = .true.\n", group_ptr->name, var_ptr2->var_array); - else - fortprintf(fd, " %s %% %s %% ioinfo %% restart = .false.\n", group_ptr->name, var_ptr2->var_array); - - if (var_ptr2->iostreams & OUTPUT0) - fortprintf(fd, " %s %% %s %% ioinfo %% output = .true.\n", group_ptr->name, var_ptr2->var_array); - else - fortprintf(fd, " %s %% %s %% ioinfo %% output = .false.\n", group_ptr->name, var_ptr2->var_array); - - fortprintf(fd, " %s %% %s %% block => b\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, "\n"); - } - else { - fortprintf(fd, " allocate(%s %% %s)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " allocate(%s %% %s %% ioinfo)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% fieldName = \'%s\'\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_file); - fortprintf(fd, " %s %% %s %% isVarArray = .false.\n", group_ptr->name, var_ptr->name_in_code); - if (var_ptr->ndims > 0) { - if(var_ptr->persistence == SCRATCH){ - fortprintf(fd, " %s %% %s %% isPersistent = .false.\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% isActive = .false.\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% array)\n", group_ptr->name, var_ptr->name_in_code); - } else if(var_ptr->persistence == PERSISTENT){ - fortprintf(fd, " %s %% %s %% isPersistent = .true.\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% isActive = .true.\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " allocate(%s %% %s %% array(", group_ptr->name, var_ptr->name_in_code); - dimlist_ptr = var_ptr->dimlist; - if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) || - !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) || - !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024)) - 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 (!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, "))\n"); - fortprintf(fd, " %s %% %s %% array = %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->default_value ); /* initialize field */ - } else if(var_ptr->persistence == PACKAGE){ - fortprintf(fd, " %s %% %s %% isPersistent = .true.\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " if ("); - write_package_options(fd, var_ptr->package_name); - fortprintf(fd, ") then\n"); - fortprintf(fd, " %s %% %s %% isActive = .true.\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " allocate(%s %% %s %% array(", group_ptr->name, var_ptr->name_in_code); - dimlist_ptr = var_ptr->dimlist; - if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) || - !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) || - !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024)) - 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 (!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, "))\n"); - if (var_ptr->vtype == INTEGER) - fortprintf(fd, " %s %% %s %% array = 0\n", group_ptr->name, var_ptr->name_in_code ); /* initialize field to zero */ - else if (var_ptr->vtype == REAL) - fortprintf(fd, " %s %% %s %% array = 0.0\n", group_ptr->name, var_ptr->name_in_code ); /* initialize field to zero */ - else if (var_ptr->vtype == CHARACTER) - fortprintf(fd, " %s %% %s %% array = \'\'\n", group_ptr->name, var_ptr->name_in_code ); /* initialize field to zero */ - fortprintf(fd, " else\n"); - fortprintf(fd, " %s %% %s %% isActive = .false.\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% array)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " endif\n"); - - } - dimlist_ptr = var_ptr->dimlist; - i = 1; - while (dimlist_ptr) { - if (!strncmp(dimlist_ptr->dim->name_in_file, "nCells", 1024) || - !strncmp(dimlist_ptr->dim->name_in_file, "nEdges", 1024) || - !strncmp(dimlist_ptr->dim->name_in_file, "nVertices", 1024)) - if (!dimlist_ptr->dim->namelist_defined) { - if(var_ptr->persistence == PERSISTENT || var_ptr->persistence == PACKAGE){ - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_code); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file); + // Add the rest of the variables from the current group. + if(var_xml->next){ + for(var_xml2 = var_xml->next; var_xml2; var_xml2 = var_xml2->next){ + vararrgroup2 = ezxml_attr(var_xml2, "array_group"); + + // var_xml2 is in the current array group + if(strncmp(vararrgroup, vararrgroup2, 1024) == 0){ + varname = ezxml_attr(var_xml2, "name"); + varpackages = ezxml_attr(var_xml2, "packages"); + varname_in_code = ezxml_attr(var_xml2, "name_in_code"); + + if(!varname_in_code){ + varname_in_code = ezxml_attr(var_xml2, "name"); + } + + + // If no packages are defined, default to var_arr packages. + if(varpackages == NULL){ + if(vararrpackages != NULL){ + varpackages = ezxml_attr(var_arr_xml, "packages"); + } + } + + fortprintf(fd, "! Define constituent var %s\n", varname); + fortprintf(fd, "! My packages are %s\n", varpackages); + + // Parse packages if they are defined + sub_spacing[0] = '\0'; + if(varpackages){ + fortprintf(fd, "%sif (", spacing); + string = strdup(varpackages); + tofree = string; + token = strsep(&string, ";"); + fortprintf(fd, "%sActive", token); + + while( (token = strsep(&string, ";")) != NULL){ + fortprintf(fd, " .or. %sActive", token); + } + + fortprintf(fd, ") then\n"); + snprintf(sub_spacing, 1024, " "); } - else { - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s+1\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_code); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file); + + fortprintf(fd, " %sindex_counter = index_counter + 1\n", sub_spacing); + fortprintf(fd, " %sif (associated(newSubPool)) then\n", sub_spacing); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, 'index_%s', index_counter)\n", sub_spacing, varname_in_code); + fortprintf(fd, " %send if\n", sub_spacing); + fortprintf(fd, " %sgroup_counter = group_counter + 1\n", sub_spacing); + fortprintf(fd, " %sif (.not. group_started) then\n", sub_spacing); + fortprintf(fd, " %s group_start = index_counter\n", sub_spacing); + fortprintf(fd, " %s if (associated(newSubPool)) then\n", sub_spacing); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, '%s_start', group_start)\n", sub_spacing, vararrgroup); + fortprintf(fd, " %s end if\n", sub_spacing); + fortprintf(fd, " %s group_started = .true.\n", sub_spacing); + fortprintf(fd, " %send if\n", sub_spacing); + + // If Packages are defined, write else clause + if(varpackages != NULL){ + fortprintf(fd, " %selse\n", sub_spacing); + fortprintf(fd, " %s if (associated(newSubPool)) then\n", sub_spacing); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, 'index_%s', -1)\n", sub_spacing, varname_in_code); + fortprintf(fd, " %s end if\n", sub_spacing); + fortprintf(fd, " %send if\n", sub_spacing); } - } - else { - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file); - } - else - if (dimlist_ptr->dim->namelist_defined) { - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file); - } - else { - fortprintf(fd, " %s %% %s %% dimSizes(%i) = %s\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_code); - fortprintf(fd, " %s %% %s %% dimNames(%i) = \'%s\'\n", group_ptr->name, var_ptr->name_in_code, i, dimlist_ptr->dim->name_in_file); - } - i++; - dimlist_ptr = dimlist_ptr->next; - } + } + } } - if (var_ptr->timedim) fortprintf(fd, " %s %% %s %% hasTimeDimension = .true.\n", group_ptr->name, var_ptr->name_in_code); - else fortprintf(fd, " %s %% %s %% hasTimeDimension = .false.\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% sendList)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% recvList)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% copyList)\n", group_ptr->name, var_ptr->name_in_code); - - if (var_ptr->iostreams & INPUT0) - fortprintf(fd, " %s %% %s %% ioinfo %% input = .true.\n", group_ptr->name, var_ptr->name_in_code); - else - fortprintf(fd, " %s %% %s %% ioinfo %% input = .false.\n", group_ptr->name, var_ptr->name_in_code); - - if (var_ptr->iostreams & SFC0) - fortprintf(fd, " %s %% %s %% ioinfo %% sfc = .true.\n", group_ptr->name, var_ptr->name_in_code); - else - fortprintf(fd, " %s %% %s %% ioinfo %% sfc = .false.\n", group_ptr->name, var_ptr->name_in_code); - - if (var_ptr->iostreams & RESTART0) - fortprintf(fd, " %s %% %s %% ioinfo %% restart = .true.\n", group_ptr->name, var_ptr->name_in_code); - else - fortprintf(fd, " %s %% %s %% ioinfo %% restart = .false.\n", group_ptr->name, var_ptr->name_in_code); - - if (var_ptr->iostreams & OUTPUT0) - fortprintf(fd, " %s %% %s %% ioinfo %% output = .true.\n", group_ptr->name, var_ptr->name_in_code); - else - fortprintf(fd, " %s %% %s %% ioinfo %% output = .false.\n", group_ptr->name, var_ptr->name_in_code); - - fortprintf(fd, " %s %% %s %% block => b\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, "\n"); - - var_list_ptr = var_list_ptr->next; - } - } - - fortprintf(fd, " end subroutine mpas_allocate_%s\n\n\n", group_ptr->name); - group_ptr = group_ptr->next; - } - fclose(fd); - - /* Definitions of deallocate subroutines */ - fd = fopen("group_dealloc_routines.inc", "w"); - group_ptr = groups; - while (group_ptr) { - fortprintf(fd, " subroutine mpas_deallocate_%s(%s)\n", group_ptr->name, group_ptr->name); - fortprintf(fd, "\n"); - fortprintf(fd, " implicit none\n"); - fortprintf(fd, "\n"); - fortprintf(fd, " type (%s_type), intent(inout) :: %s\n", group_ptr->name, group_ptr->name); - fortprintf(fd, "\n"); - - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - if (strncmp(var_ptr->var_array, "-", 1024) != 0) { - memcpy(var_array, var_ptr->var_array, 1024); - memcpy(array_class, var_ptr->array_class, 1024); - i = 0; - while (var_list_ptr && strncmp(var_array, var_list_ptr->var->var_array, 1024) == 0) { - i++; - var_list_ptr2 = var_list_ptr; - var_list_ptr = var_list_ptr->next; - } - fortprintf(fd, " if(associated(%s %% %s %% array)) then\n", group_ptr->name, var_list_ptr2->var->var_array); - fortprintf(fd, " deallocate(%s %% %s %% array)\n", group_ptr->name, var_list_ptr2->var->var_array); - fortprintf(fd, " end if\n"); - fortprintf(fd, " deallocate(%s %% %s %% ioinfo)\n", group_ptr->name, var_list_ptr2->var->var_array); - fortprintf(fd, " call mpas_deallocate_attlist(%s %% %s %% attList)\n", group_ptr->name, var_list_ptr2->var->var_array); - fortprintf(fd, " deallocate(%s %% %s)\n\n", group_ptr->name, var_list_ptr2->var->var_array); - } - else { - if (var_ptr->ndims > 0) { - fortprintf(fd, " if(associated(%s %% %s %% array)) then\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " deallocate(%s %% %s %% array)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n"); - fortprintf(fd, " deallocate(%s %% %s %% ioinfo)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " call mpas_deallocate_attlist(%s %% %s %% attList)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " deallocate(%s %% %s)\n\n", group_ptr->name, var_ptr->name_in_code); - } - else { - fortprintf(fd, " deallocate(%s %% %s %% ioinfo)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " call mpas_deallocate_attlist(%s %% %s %% attList)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " deallocate(%s %% %s)\n\n", group_ptr->name, var_ptr->name_in_code); - } - var_list_ptr = var_list_ptr->next; - } - } - - fortprintf(fd, " end subroutine mpas_deallocate_%s\n\n\n", group_ptr->name); - group_ptr = group_ptr->next; - } - fclose(fd); - - /* Definitions of copy subroutines */ - fd = fopen("group_copy_routines.inc", "w"); - group_ptr = groups; - while (group_ptr) { - fortprintf(fd, " subroutine mpas_copy_%s(dest, src)\n", group_ptr->name); - fortprintf(fd, "\n"); - fortprintf(fd, " implicit none\n"); - fortprintf(fd, "\n"); - fortprintf(fd, " type (%s_type), intent(in) :: src\n", group_ptr->name); - fortprintf(fd, " type (%s_type), intent(inout) :: dest\n", group_ptr->name); - fortprintf(fd, "\n"); - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - if (strncmp(var_ptr->var_array, "-", 1024) != 0) { - memcpy(var_array, var_ptr->var_array, 1024); - memcpy(array_class, var_ptr->array_class, 1024); - i = 0; - while (var_list_ptr && strncmp(var_array, var_list_ptr->var->var_array, 1024) == 0) { - i++; - var_list_ptr2 = var_list_ptr; - var_list_ptr = var_list_ptr->next; - } - var_ptr2 = var_list_ptr2->var; - if (var_ptr2->ndims > 0) { - fortprintf(fd, " if (associated(dest %% %s %% array) .and. associated(src %% %s %% array)) then\n", var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " dest %% %s %% array = src %% %s %% array\n", var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " end if\n"); - } else { - fortprintf(fd, " dest %% %s %% scalar = src %% %s %% scalar\n", var_ptr2->var_array, var_ptr2->var_array); + fortprintf(fd, " %sif (.not. group_started) then\n", sub_spacing); + fortprintf(fd, " %s if (associated(newSubPool)) then\n", sub_spacing); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, '%s_start', -1)\n", sub_spacing, vararrgroup); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, '%s_end', -1)\n", sub_spacing, vararrgroup); + fortprintf(fd, " %s end if\n", sub_spacing); + fortprintf(fd, " %selse\n", sub_spacing); + fortprintf(fd, " %s group_started = .false.\n", sub_spacing); + fortprintf(fd, " %s if (associated(newSubPool)) then\n", sub_spacing); + fortprintf(fd, " %s call mpas_pool_add_dimension(newSubPool, '%s_end', index_counter)\n", sub_spacing, vararrgroup); + fortprintf(fd, " %s end if\n", sub_spacing); + fortprintf(fd, " %send if\n", sub_spacing); + fortprintf(fd, "! End of group \n", vararrgroup); + } + } + + fortprintf(fd, "\n"); + + // Setup constituent names + fortprintf(fd, " numConstituents = index_counter\n"); + fortprintf(fd, " if (associated(newSubPool)) then\n"); + fortprintf(fd, " call mpas_pool_add_dimension(newSubPool, 'num_%s', numConstituents)\n", vararrname); + fortprintf(fd, " end if\n"); + + for(time_lev = 1; time_lev <= time_levs; time_lev++){ + fortprintf(fd, "! Defining time level %d\n", time_lev); + fortprintf(fd, " allocate( %s(%d) %% constituentNames(numConstituents) )\n", pointer_name, time_lev); + fortprintf(fd, " allocate(%s(%d) %% ioinfo)\n", pointer_name, time_lev); + fortprintf(fd, " %s(%d) %% fieldName = '%s'\n", pointer_name, time_lev, vararrname); + if (hasTime) { + fortprintf(fd, " %s(%d) %% hasTimeDimension = .true.\n", pointer_name, time_lev); + } else { + fortprintf(fd, " %s(%d) %% hasTimeDimension = .false.\n", pointer_name, time_lev); + } + fortprintf(fd, " %s(%d) %% isVarArray = .true.\n", pointer_name, time_lev); + if(ndims > 0){ + if(persistence == SCRATCH){ + fortprintf(fd, " %s(%d) %% isPersistent = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + } else { + fortprintf(fd, " %s(%d) %% isPersistent = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); } - } - else { - if (var_ptr->ndims > 0) { - fortprintf(fd, " if (associated(dest %% %s %% array) .and. associated(src %% %s %% array)) then\n", var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " dest %% %s %% array = src %% %s %% array\n", var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " end if\n"); - } else { - fortprintf(fd, " dest %% %s %% scalar = src %% %s %% scalar\n", var_ptr->name_in_code, var_ptr->name_in_code); + } + fortprintf(fd, "\n"); + for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ + varname = ezxml_attr(var_xml, "name"); + varname_in_code = ezxml_attr(var_xml, "name_in_code"); + + if(!varname_in_code){ + varname_in_code = ezxml_attr(var_xml, "name"); + } + + fortprintf(fd, " if (associated(newSubPool)) then\n"); + fortprintf(fd, " call mpas_pool_get_dimension(newSubPool, 'index_%s', const_index)\n", varname_in_code); + fortprintf(fd, " end if\n"); + fortprintf(fd, " if (index_counter > 0) then\n", spacing); + fortprintf(fd, " %s(%d) %% constituentNames(const_index) = '%s'\n", pointer_name, time_lev, varname); + fortprintf(fd, " end if\n", spacing); + } + + fortprintf(fd, "\n"); + + // Setup dimensions + fortprintf(fd, "! Setup dimensions for \n", vararrname); + i = 1; + fortprintf(fd, " %s(%d) %% dimNames(%d) = 'num_%s'\n", pointer_name, time_lev, i, vararrname); + fortprintf(fd, " %s(%d) %% dimSizes(%d) = numConstituents\n", pointer_name, time_lev, i); + + string = strdup(vararrdims); + tofree = string; + token = strsep(&string, " "); + + if(strncmp(token, "Time", 1024) != 0){ + i++; + if(strncmp(token, "nCells", 1024) == 0 || strncmp(token, "nEdges", 1024) == 0 || strncmp(token, "nVertices", 1024) == 0){ + fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s(%d) %% dimSizes(%d) = %s+1\n", pointer_name, time_lev, i, token); + } else { + fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s(%d) %% dimSizes(%d) = %s\n", pointer_name, time_lev, i, token); + } + } + while( (token = strsep(&string, " ")) != NULL){ + if(strncmp(token, "Time", 1024) != 0){ + i++; + if(strncmp(token, "nCells", 1024) == 0 || strncmp(token, "nEdges", 1024) == 0 || strncmp(token, "nVertices", 1024) == 0){ + fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s(%d) %% dimSizes(%d) = %s+1\n", pointer_name, time_lev, i, token); + } else { + fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s(%d) %% dimSizes(%d) = %s\n", pointer_name, time_lev, i, token); + } + } + } + free(tofree); + + fortprintf(fd, "\n"); + + // Setup array pointer + fortprintf(fd, "! Allocate space for data\n"); + if(!vararrpersistence || strcmp(vararrpersistence, "scratch") != 0){ + switch(ndims){ + default: + break; + case 1: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1)))\n", pointer_name, time_lev, pointer_name, time_lev); + break; + case 2: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1), %s(%d) %% dimSizes(2)))\n", pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev); + break; + case 3: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1), %s(%d) %% dimSizes(2), %s(%d) %% dimSizes(3)))\n", pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev); + break; + case 4: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1), %s(%d) %% dimSizes(2), %s(%d) %% dimSizes(3), %s(%d) %% dimSizes(4)))\n", pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev); + break; + case 5: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1), %s(%d) %% dimSizes(2), %s(%d) %% dimSizes(3), %s(%d) %% dimSizes(4), %s(%d) %% dimSizes(5)))\n", pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev); + break; + } + + fortprintf(fd, " %s(%d) %% array = %s\n", pointer_name, time_lev, default_value); + + } else { + if(ndims > 0){ + fortprintf(fd, " nullify(%s(%d) %% array)\n", pointer_name, time_lev); } - var_list_ptr = var_list_ptr->next; - } - } - fortprintf(fd, "\n"); - fortprintf(fd, " end subroutine mpas_copy_%s\n\n\n", group_ptr->name); - group_ptr = group_ptr->next; - } - fclose(fd); - - /* Definitions of shift_time_level subroutines */ - fd = fopen("group_shift_level_routines.inc", "w"); - group_ptr = groups; - while (group_ptr) { - if (group_ptr->vlist != NULL && group_ptr->ntime_levs > 1) { - fortprintf(fd, " subroutine mpas_shift_time_levels_%s(%s)\n", group_ptr->name, group_ptr->name); - fortprintf(fd, "\n"); - fortprintf(fd, " implicit none\n"); - fortprintf(fd, "\n"); - fortprintf(fd, " type (%s_multilevel_type), intent(inout) :: %s\n", group_ptr->name, group_ptr->name); - fortprintf(fd, "\n"); - fortprintf(fd, " integer :: i\n"); - fortprintf(fd, " real (kind=RKIND) :: real0d\n"); - fortprintf(fd, " real (kind=RKIND), dimension(:), pointer :: real1d\n"); - fortprintf(fd, " real (kind=RKIND), dimension(:,:), pointer :: real2d\n"); - fortprintf(fd, " real (kind=RKIND), dimension(:,:,:), pointer :: real3d\n"); - fortprintf(fd, " integer :: int0d\n"); - fortprintf(fd, " integer, dimension(:), pointer :: int1d\n"); - fortprintf(fd, " integer, dimension(:,:), pointer :: int2d\n"); - fortprintf(fd, " integer, dimension(:,:,:), pointer :: int3d\n"); - fortprintf(fd, " character (len=64) :: char0d\n"); - fortprintf(fd, " character (len=64), dimension(:), pointer :: char1d\n"); - fortprintf(fd, "\n"); - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - - if (strncmp(var_ptr->var_array, "-", 1024) != 0) - { - if (var_ptr->vtype == INTEGER) sprintf(type_str, "int%id", var_ptr->ndims+1); - else if (var_ptr->vtype == REAL) sprintf(type_str, "real%id", var_ptr->ndims+1); - else if (var_ptr->vtype == CHARACTER) sprintf(type_str, "char%id", var_ptr->ndims+1); - - memcpy(var_array, var_ptr->var_array, 1024); - - while (var_list_ptr && strncmp(var_array, var_list_ptr->var->var_array, 1024) == 0) - { - var_list_ptr2 = var_list_ptr; - var_list_ptr = var_list_ptr->next; - } - var_ptr2 = var_list_ptr2->var; - - fortprintf(fd, " %s => %s %% time_levs(1) %% %s %% %s %% array\n", type_str, group_ptr->name, group_ptr->name, var_ptr2->var_array); - - fortprintf(fd, " do i=1,%s %% nTimeLevels-1\n", group_ptr->name); - fortprintf(fd, " %s %% time_levs(i) %% %s %% %s %% array => %s %% time_levs(i+1) %% %s %% %s %% array\n", group_ptr->name, group_ptr->name, var_ptr2->var_array, group_ptr->name, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end do\n"); - - fortprintf(fd, " %s %% time_levs(%s %% nTimeLevels) %% %s %% %s %% array=> %s\n\n", group_ptr->name, group_ptr->name, group_ptr->name, var_ptr2->var_array, type_str); - } - else { - - if (var_ptr->vtype == INTEGER) sprintf(type_str, "int%id", var_ptr->ndims); - else if (var_ptr->vtype == REAL) sprintf(type_str, "real%id", var_ptr->ndims); - else if (var_ptr->vtype == CHARACTER) sprintf(type_str, "char%id", var_ptr->ndims); - - if (var_ptr->ndims > 0) - fortprintf(fd, " %s => %s %% time_levs(1) %% %s %% %s %% array\n", type_str, group_ptr->name, group_ptr->name, var_ptr->name_in_code); - else - fortprintf(fd, " %s = %s %% time_levs(1) %% %s %% %s %% scalar\n", type_str, group_ptr->name, group_ptr->name, var_ptr->name_in_code); - - fortprintf(fd, " do i=1,%s %% nTimeLevels-1\n", group_ptr->name); - if (var_ptr->ndims > 0) - fortprintf(fd, " %s %% time_levs(i) %% %s %% %s %% array => %s %% time_levs(i+1) %% %s %% %s %% array\n", group_ptr->name, group_ptr->name, var_ptr->name_in_code, group_ptr->name, group_ptr->name, var_ptr->name_in_code); - else - fortprintf(fd, " %s %% time_levs(i) %% %s %% %s %% scalar = %s %% time_levs(i+1) %% %s %% %s %% scalar\n", group_ptr->name, group_ptr->name, var_ptr->name_in_code, group_ptr->name, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end do\n"); - - if (var_ptr->ndims > 0) - fortprintf(fd, " %s %% time_levs(%s %% nTimeLevels) %% %s %% %s %% array=> %s\n\n", group_ptr->name, group_ptr->name, group_ptr->name, var_ptr->name_in_code, type_str); - else - fortprintf(fd, " %s %% time_levs(%s %% nTimeLevels) %% %s %% %s %% scalar = %s\n\n", group_ptr->name, group_ptr->name, group_ptr->name, var_ptr->name_in_code, type_str); - - var_list_ptr = var_list_ptr->next; - } - } - fortprintf(fd, "\n"); - fortprintf(fd, " end subroutine mpas_shift_time_levels_%s\n\n\n", group_ptr->name); - } - group_ptr = group_ptr->next; - } - fclose(fd); - - - /* Definitions of deallocate subroutines */ - fd = fopen("field_links.inc", "w"); - - /* subroutine to call link subroutine for every field type */ - fortprintf(fd, " subroutine mpas_create_field_links(b)\n\n"); - - fortprintf(fd, " implicit none\n"); - - fortprintf(fd, " type (block_type), pointer :: b\n"); - fortprintf(fd, " type (block_type), pointer :: prev, next\n\n"); - - fortprintf(fd, " if (associated(b %% prev)) then\n"); - fortprintf(fd, " prev => b %% prev\n"); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(prev)\n"); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if (associated(b %% next)) then\n"); - fortprintf(fd, " next => b %% next\n"); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(next)\n"); - fortprintf(fd, " end if\n\n"); - - group_ptr = groups; - while (group_ptr) - { - var_list_ptr = group_ptr->vlist; - - if (!group_ptr->vlist) { - group_ptr = group_ptr->next; - continue; - } - - if (group_ptr->ntime_levs > 1) { - for(i=1; i<=group_ptr->ntime_levs; i++) { - fortprintf(fd, " if (associated(next) .and. associated(prev)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s, ", group_ptr->name, group_ptr->name, i, group_ptr->name, i); - fortprintf(fd, " prev = prev %% %s %% time_levs(%i) %% %s,", group_ptr->name, i, group_ptr->name); - fortprintf(fd, " next = next %% %s %% time_levs(%i) %% %s)\n", group_ptr->name, i, group_ptr->name); - fortprintf(fd, " else if (associated(next)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s, next = next %% %s %% time_levs(%i) %% %s)\n", group_ptr->name, group_ptr->name, i, group_ptr->name, group_ptr->name, i, group_ptr->name); - fortprintf(fd, " else if (associated(prev)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s, prev = prev %% %s %% time_levs(%i) %% %s)\n", group_ptr->name, group_ptr->name, i, group_ptr->name, group_ptr->name, i, group_ptr->name); - fortprintf(fd, " else\n"); - fortprintf(fd, " call mpas_create_%s_links(b %% %s %% time_levs(%i) %% %s)\n", group_ptr->name, group_ptr->name, i, group_ptr->name); - fortprintf(fd, " end if\n\n"); - } - } - else { - fortprintf(fd, " if (associated(next) .and. associated(prev)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(b %% %s, prev = prev %% %s, next = next %% %s)\n", group_ptr->name, group_ptr->name, group_ptr->name, group_ptr->name); - fortprintf(fd, " else if (associated(next)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(b %% %s, next = next %% %s)\n", group_ptr->name, group_ptr->name, group_ptr->name); - fortprintf(fd, " else if (associated(prev)) then\n"); - fortprintf(fd, " call mpas_create_%s_links(b %% %s, prev = prev %% %s)\n", group_ptr->name, group_ptr->name, group_ptr->name); - fortprintf(fd, " else\n"); - fortprintf(fd, " call mpas_create_%s_links(b %% %s)\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " end if\n\n"); - } - - group_ptr = group_ptr->next; - } - fortprintf(fd, " end subroutine mpas_create_field_links\n\n\n"); - - /* subroutines for linking specific field type */ - group_ptr = groups; - - while (group_ptr) { - fortprintf(fd, " subroutine mpas_create_%s_links(%s, prev, next)\n\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " implicit none\n"); - fortprintf(fd, " type (%s_type), pointer :: %s\n", group_ptr->name, group_ptr->name); - fortprintf(fd, " type (%s_type), pointer, optional :: prev, next\n", group_ptr->name); - - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - if (strncmp(var_ptr->var_array, "-", 1024) != 0) { - memcpy(var_array, var_ptr->var_array, 1024); - memcpy(array_class, var_ptr->array_class, 1024); - while (var_list_ptr && strncmp(var_array, var_list_ptr->var->var_array, 1024) == 0) { - var_list_ptr2 = var_list_ptr; - var_list_ptr = var_list_ptr->next; - } - var_ptr2 = var_list_ptr2->var; - get_outer_dim(var_ptr2, outer_dim); - - if (strncmp("nCells",outer_dim,1024) == 0) { - fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% cellsToSend\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% cellsToRecv\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% cellsToCopy\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " if(present(prev)) then\n"); - fortprintf(fd, " %s %% %s %% prev => prev %% %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(present(next)) then\n"); - fortprintf(fd, " %s %% %s %% next => next %% %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n\n"); - } - else if (strncmp("nEdges",outer_dim,1024) == 0) { - fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% edgesToSend\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% edgesToRecv\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% edgesToCopy\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " if(present(prev)) then\n"); - fortprintf(fd, " %s %% %s %% prev => prev %% %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(present(next)) then\n"); - fortprintf(fd, " %s %% %s %% next => next %% %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n\n"); - } - else if (strncmp("nVertices",outer_dim,1024) == 0) { - fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% verticesToSend\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% verticesToRecv\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% verticesToCopy\n", group_ptr->name, var_ptr2->var_array, group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " if(present(prev)) then\n"); - fortprintf(fd, " %s %% %s %% prev => prev %% %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(present(next)) then\n"); - fortprintf(fd, " %s %% %s %% next => next %% %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n\n"); - } else { - fortprintf(fd, " nullify(%s %% %s %% sendList)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " nullify(%s %% %s %% recvList)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " nullify(%s %% %s %% copyList)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " if(present(prev)) then\n"); - fortprintf(fd, " %s %% %s %% prev => prev %% %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(present(next)) then\n"); - fortprintf(fd, " %s %% %s %% next => next %% %s\n", group_ptr->name, var_ptr2->var_array, var_ptr2->var_array); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr2->var_array); - fortprintf(fd, " end if\n\n"); - - } - fortprintf(fd, "\n"); - } - else - { - if (var_ptr->ndims > 0) - { - get_outer_dim(var_ptr, outer_dim); - - if (strncmp("nCells",outer_dim,1024) == 0) { - fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% cellsToSend\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% cellsToRecv\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% cellsToCopy\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " if(present(prev)) then\n"); - fortprintf(fd, " %s %% %s %% prev => prev %% %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(present(next)) then\n"); - fortprintf(fd, " %s %% %s %% next => next %% %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n\n"); - } - else if (strncmp("nEdges",outer_dim,1024) == 0) { - fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% edgesToSend\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% edgesToRecv\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% edgesToCopy\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " if(present(prev)) then\n"); - fortprintf(fd, " %s %% %s %% prev => prev %% %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(present(next)) then\n"); - fortprintf(fd, " %s %% %s %% next => next %% %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n\n"); - } - else if (strncmp("nVertices",outer_dim,1024) == 0) { - fortprintf(fd, " %s %% %s %% sendList => %s %% %s %% block %% parinfo %% verticesToSend\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% recvList => %s %% %s %% block %% parinfo %% verticesToRecv\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " %s %% %s %% copyList => %s %% %s %% block %% parinfo %% verticesToCopy\n", group_ptr->name, var_ptr->name_in_code, group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " if(present(prev)) then\n"); - fortprintf(fd, " %s %% %s %% prev => prev %% %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(present(next)) then\n"); - fortprintf(fd, " %s %% %s %% next => next %% %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n\n"); - } else { - fortprintf(fd, " nullify(%s %% %s %% sendList)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% recvList)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " nullify(%s %% %s %% copyList)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " if(present(prev)) then\n"); - fortprintf(fd, " %s %% %s %% prev => prev %% %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% prev)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(present(next)) then\n"); - fortprintf(fd, " %s %% %s %% next => next %% %s\n", group_ptr->name, var_ptr->name_in_code, var_ptr->name_in_code); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(%s %% %s %% next)\n", group_ptr->name, var_ptr->name_in_code); - fortprintf(fd, " end if\n\n"); - } - fortprintf(fd, "\n"); - } - var_list_ptr = var_list_ptr->next; - } - } - - fortprintf(fd, " end subroutine mpas_create_%s_links\n\n\n", group_ptr->name); - - group_ptr = group_ptr->next; - } - fclose(fd); - -} - - -void gen_reads(struct group_list * groups, struct variable * vars, struct dimension * dims) -{ - struct variable * var_ptr; - struct variable_list * var_list_ptr, *var_list_ptr2; - struct dimension * dim_ptr; - struct dimension_list * dimlist_ptr, * lastdim; - struct group_list * group_ptr; - struct dtable * dictionary; - FILE * fd, *fd2; - char vtype[5]; - char fname[32]; - char var_array[1024]; - char struct_deref[1024]; - char * cp1, * cp2; - int i, j; - int ivtype; - - - fd = fopen("add_input_fields.inc", "w"); - - group_ptr = groups; - while (group_ptr) { - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - - if (group_ptr->ntime_levs > 1) - snprintf(struct_deref, 1024, "blocklist %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name); - else - snprintf(struct_deref, 1024, "blocklist %% %s", group_ptr->name); - - if (strncmp(var_ptr->var_array, "-", 1024) != 0) { - fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &\n", struct_deref, var_ptr->var_array); - fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &\n", struct_deref, var_ptr->var_array); - fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then\n", struct_deref, var_ptr->var_array); - memcpy(var_array, var_ptr->var_array, 1024); -/* fortprintf(fd, " write(0,*) \'adding input field %s\'\n", var_ptr->var_array); */ - fortprintf(fd, " call MPAS_streamAddField(input_obj %% io_stream, %s %% %s, nferr)\n", struct_deref, var_ptr->var_array); - while (var_list_ptr && strncmp(var_array, var_list_ptr->var->var_array, 1024) == 0) { - var_list_ptr2 = var_list_ptr; - var_list_ptr = var_list_ptr->next; - } - var_list_ptr = var_list_ptr2; - } - else { - fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then\n", struct_deref, var_ptr->name_in_code); -/* fortprintf(fd, " write(0,*) \'adding input field %s\'\n", var_ptr->name_in_code); */ - fortprintf(fd, " call MPAS_streamAddField(input_obj %% io_stream, %s %% %s, nferr)\n", struct_deref, var_ptr->name_in_code); - } - - fortprintf(fd, " end if\n\n"); - - if (var_list_ptr) var_list_ptr = var_list_ptr->next; - } - group_ptr = group_ptr->next; - } - - fclose(fd); - - - fd = fopen("exchange_input_field_halos.inc", "w"); - fd2 = fopen("non_decomp_copy_input_fields.inc", "w"); - - group_ptr = groups; - while (group_ptr) { - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - - dimlist_ptr = var_ptr->dimlist; - i = 1; - if(var_ptr->persistence == PERSISTENT || var_ptr->persistence == PACKAGE){ - while (dimlist_ptr) { - if (i == var_ptr->ndims) { - - if (group_ptr->ntime_levs > 1) { - snprintf(struct_deref, 1024, "domain %% blocklist %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name); - } else { - snprintf(struct_deref, 1024, "domain %% blocklist %% %s", group_ptr->name); - } - - if (!strncmp(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 (strncmp(var_ptr->var_array, "-", 1024) != 0) { - fortprintf(fd, " if (%s %% %s %% isPersistent .and. %s %% %s %% isActive) then\n", struct_deref, var_ptr->var_array, struct_deref, var_ptr->var_array); - fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &\n", struct_deref, var_ptr->var_array); - fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &\n", struct_deref, var_ptr->var_array); - fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then\n", struct_deref, var_ptr->var_array); - memcpy(var_array, var_ptr->var_array, 1024); -/* fortprintf(fd, " write(0,*) \'exchange halo for %s\'\n", var_ptr->var_array); */ - fortprintf(fd, " call mpas_dmpar_exch_halo_field(%s %% %s)\n", struct_deref, var_ptr->var_array); - while (var_list_ptr && strncmp(var_array, var_list_ptr->var->var_array, 1024) == 0) { - var_list_ptr2 = var_list_ptr; - var_list_ptr = var_list_ptr->next; - } - var_list_ptr = var_list_ptr2; - } - else { - fortprintf(fd, " if (%s %% %s %% isPersistent .and. %s %% %s %% isActive) then\n", struct_deref, var_ptr->name_in_code, struct_deref, var_ptr->name_in_code); - fortprintf(fd, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then\n", struct_deref, var_ptr->name_in_code); -/* fortprintf(fd, " write(0,*) \'exchange halo for %s\'\n", var_ptr->name_in_code); */ - fortprintf(fd, " call mpas_dmpar_exch_halo_field(%s %% %s)\n", struct_deref, var_ptr->name_in_code); - } - - fortprintf(fd, " end if\n\n"); - fortprintf(fd, " end if\n\n"); - - } else { - fortprintf(fd2, " if (%s %% %s %% isPersistent .and. %s %% %s %% isActive) then\n", struct_deref, var_ptr->name_in_code, struct_deref, var_ptr->name_in_code); - fortprintf(fd2, " if ((%s %% %s %% ioinfo %% input .and. input_obj %% stream == STREAM_INPUT) .or. &\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd2, " (%s %% %s %% ioinfo %% restart .and. input_obj %% stream == STREAM_RESTART) .or. &\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd2, " (%s %% %s %% ioinfo %% sfc .and. input_obj %% stream == STREAM_SFC)) then\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd2, " call mpas_dmpar_copy_field(%s %% %s)\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd2, " end if\n\n"); - fortprintf(fd2, " end if\n\n"); - } - } - - i++; - dimlist_ptr = dimlist_ptr -> next; - } - } - - if (var_list_ptr) var_list_ptr = var_list_ptr->next; - } - group_ptr = group_ptr->next; - } - - fclose(fd); - fclose(fd2); - -} - -void gen_packages(struct package * pkgs){ - FILE * fd; - struct package * pkg_ptr; - - fd = fopen("define_packages.inc", "w"); - - for (pkg_ptr = pkgs; pkg_ptr; pkg_ptr = pkg_ptr->next) { - if (strlen(pkg_ptr->name) > 0) { - fortprintf(fd, " logical :: %sActive = .false.\n", pkg_ptr->name); } + + fortprintf(fd, " nullify(%s(%d) %% next)\n", pointer_name, time_lev); + fortprintf(fd, " nullify(%s(%d) %% prev)\n", pointer_name, time_lev); + fortprintf(fd, " nullify(%s(%d) %% sendList)\n", pointer_name, time_lev); + fortprintf(fd, " nullify(%s(%d) %% recvList)\n", pointer_name, time_lev); + fortprintf(fd, " nullify(%s(%d) %% copyList)\n", pointer_name, time_lev); + fortprintf(fd, " %s(%d) %% block => block\n", pointer_name, time_lev); } - fclose(fd); -} + // Parse packages if they are defined + fortprintf(fd, "\n"); + spacing[0] = '\0'; + if(vararrpackages != NULL){ + fortprintf(fd, " if ("); + string = strdup(vararrpackages); + tofree = string; + token = strsep(&string, ";"); + fortprintf(fd, "%sActive", token); + + while( (token = strsep(&string, ";")) != NULL){ + fortprintf(fd, " .or. %sActive", token); + } + + fortprintf(fd, ") then\n"); + snprintf(spacing, 1024, " "); + } + + + // Add field to pool + fortprintf(fd, "! Add field to pool\n"); + for(time_lev = 1; time_lev <= time_levs; time_lev++){ + fortprintf(fd, "%s%s(%d) %% isActive = .true.\n", spacing, pointer_name, time_lev); + } + fortprintf(fd, "%scall mpas_pool_add_field(newSubPool, '%s', %s)\n", spacing, vararrname_in_code, pointer_name); + + if(vararrpackages != NULL) { + fortprintf(fd, " end if\n"); + } + + fortprintf(fd, " call mpas_pool_add_field(block %% allFields, '%s', %s)\n", vararrname, pointer_name); + fortprintf(fd, "\n"); + + return 0; +}/*}}}*/ + + +int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVar, const char * corename)/*{{{*/ +{ + ezxml_t struct_xml, var_xml, var_xml2; + ezxml_t packages_xml, package_xml; + ezxml_t streams_xml, stream_xml, streams_xml2, stream_xml2; + + const char *structtimelevs, *vartimelevs; + const char *structname, *structlevs, *structpackages; + const char *substructname; + const char *varname, *varpersistence, *vartype, *vardims, *varunits, *vardesc, *vararrgroup, *varstreams, *vardefaultval, *varpackages; + const char *varname2, *vararrgroup2; + const char *varname_in_code; + const char *streamname, *streamname2; + const char *packagename; + + int err; + + int iostreams; + int i, skip_var, skip_stream; + int time_lev, time_levs; + int ndims, type, hasTime, decomp, in_stream; + int persistence; + char *string, *tofree, *token; + char pointer_name[1024]; + char package_spacing[1024]; + char default_value[1024]; + + var_xml = currentVar; + + structname = ezxml_attr(superStruct, "name"); + structtimelevs = ezxml_attr(superStruct, "time_levs"); + + // Define independent variables + varname = ezxml_attr(var_xml, "name"); + vartype = ezxml_attr(var_xml, "type"); + vardims = ezxml_attr(var_xml, "dimensions"); + varpersistence = ezxml_attr(var_xml, "persistence"); + varpackages = ezxml_attr(var_xml, "packages"); + vardefaultval = ezxml_attr(var_xml, "default_value"); + vartimelevs = ezxml_attr(var_xml, "time_levs"); + varname_in_code = ezxml_attr(var_xml, "name_in_code"); + + if(!varname_in_code){ + varname_in_code = ezxml_attr(var_xml, "name"); + } + + if(!vartimelevs){ + vartimelevs = ezxml_attr(superStruct, "time_levs"); + } + + if(vartimelevs){ + time_levs = atoi(vartimelevs); + if(time_levs < 1){ + time_levs = 1; + } + } else { + time_levs = 1; + } + + persistence = check_persistence(varpersistence); + + fortprintf(fd, "! Define variable %s\n", varname); + + + // Determine field type and default value. + get_field_information(vartype, vardefaultval, default_value, &type); + + // Determine ndims, hasTime, and decomp type + get_dimension_information(vardims, &ndims, &hasTime, &decomp); + + // Determine name of pointer for this field. + set_pointer_name(type, ndims, pointer_name); + fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + + for(time_lev = 1; time_lev <= time_levs; time_lev++){ + fortprintf(fd, "\n"); + fortprintf(fd, "! Setting up time level %d\n", time_lev); + fortprintf(fd, " allocate(%s(%d) %% ioinfo)\n", pointer_name, time_lev); + fortprintf(fd, " %s(%d) %% fieldName = '%s'\n", pointer_name, time_lev, varname); + fortprintf(fd, " %s(%d) %% isVarArray = .false.\n", pointer_name, time_lev); + if(hasTime) { + fortprintf(fd, " %s(%d) %% hasTimeDimension = .true.\n", pointer_name, time_lev); + } else { + fortprintf(fd, " %s(%d) %% hasTimeDimension = .false.\n", pointer_name, time_lev); + } + + if(ndims > 0){ + if(persistence == SCRATCH){ + fortprintf(fd, " %s(%d) %% isPersistent = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + } else { + fortprintf(fd, " %s(%d) %% isPersistent = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + } + + // Setup dimensions + fortprintf(fd, "! Setting up dimensions\n"); + string = strdup(vardims); + tofree = string; + i = 1; + token = strsep(&string, " "); + if(strncmp(token, "Time", 1024) != 0){ + fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + if(strcmp(token, "nCells") == 0 || strcmp(token, "nEdges") == 0 || strcmp(token, "nVertices") == 0){ + fortprintf(fd, " %s(%d) %% dimSizes(%d) = %s + 1\n", pointer_name, time_lev, i, token); + } else { + fortprintf(fd, " %s(%d) %% dimSizes(%d) = %s\n", pointer_name, time_lev, i, token); + } + i++; + } + while( (token = strsep(&string, " ")) != NULL){ + if(strncmp(token, "Time", 1024) != 0){ + fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + if(strcmp(token, "nCells") == 0 || strcmp(token, "nEdges") == 0 || strcmp(token, "nVertices") == 0){ + fortprintf(fd, " %s(%d) %% dimSizes(%d) = %s + 1\n", pointer_name, time_lev, i, token); + } else { + fortprintf(fd, " %s(%d) %% dimSizes(%d) = %s\n", pointer_name, time_lev, i, token); + } + i++; + } + } + free(tofree); + + + + fortprintf(fd, "! Allocate space for data\n"); + switch(ndims){ + default: + break; + case 1: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1)))\n", pointer_name, time_lev, pointer_name, time_lev); + break; + case 2: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1), %s(%d) %% dimSizes(2)))\n", + pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev); + break; + case 3: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1), %s(%d) %% dimSizes(2), %s(%d) %% dimSizes(3)))\n", + pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev); + break; + case 4: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1), %s(%d) %% dimSizes(2), %s(%d) %% dimSizes(3), %s(%d) %% dimSizes(4)))\n", + pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev); + break; + case 5: + fortprintf(fd, " allocate(%s(%d) %% array(%s(%d) %% dimSizes(1), %s(%d) %% dimSizes(2), %s(%d) %% dimSizes(3), %s(%d) %% dimSizes(4), %s(%d) %% dimSizes(5)))\n", + pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev, pointer_name, time_lev); + break; + } + + fortprintf(fd, " %s(%d) %% array = %s\n", pointer_name, time_lev, default_value); + } else if(ndims == 0){ + fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); + } + + + fortprintf(fd, " nullify(%s(%d) %% next)\n", pointer_name, time_lev); + fortprintf(fd, " nullify(%s(%d) %% prev)\n", pointer_name, time_lev); + fortprintf(fd, " nullify(%s(%d) %% sendList)\n", pointer_name, time_lev); + fortprintf(fd, " nullify(%s(%d) %% recvList)\n", pointer_name, time_lev); + fortprintf(fd, " nullify(%s(%d) %% copyList)\n", pointer_name, time_lev); + fortprintf(fd, " %s(%d) %% block => block\n", pointer_name, time_lev); + } + + // Parse packages if they are defined + fortprintf(fd, "\n"); + snprintf(package_spacing, 1024, " "); + if(varpackages != NULL){ + fortprintf(fd, " if ("); + string = strdup(varpackages); + tofree = string; + token = strsep(&string, ";"); + fortprintf(fd, "%sActive", token); + + while( (token = strsep(&string, ";")) != NULL){ + fortprintf(fd, " .or. %sActive", token); + } + + fortprintf(fd, ") then\n"); + snprintf(package_spacing, 1024, " "); + } + + for(time_lev = 1; time_lev <= time_levs; time_lev++){ + fortprintf(fd, "%s%s(%d) %% isActive = .true.\n", package_spacing, pointer_name, time_lev); + } + fortprintf(fd, "%scall mpas_pool_add_field(newSubPool, '%s', %s)\n", package_spacing , varname_in_code, pointer_name); + + if(varpackages != NULL){ + fortprintf(fd, " end if\n"); + } + fortprintf(fd, " call mpas_pool_add_field(block %% allFields, '%s', %s)\n", varname, pointer_name); + fortprintf(fd, "\n"); + + return 0; +}/*}}}*/ + + +int parse_struct(FILE *fd, ezxml_t registry, ezxml_t superStruct, int subpool, const char *parentname, const char * corename)/*{{{*/ +{ + ezxml_t dims_xml, dim_xml; + ezxml_t struct_xml, var_arr_xml, var_xml, var_xml2; + ezxml_t struct_xml2; + ezxml_t packages_xml, package_xml; + + const char *dimname; + const char *structname, *structlevs, *structpackages; + const char *structname2; + const char *substructname; + const char *streamname, *streamname2; + const char *packagename; + const char *structnameincode; + + char *string, *tofree, *token; + char spacing[1024]; + char core_string[1024]; + char pool_name[1024]; + char package_list[2048]; + + int skip_struct, no_packages; + int err; + + sprintf(core_string, "_%s_", corename); + + // For now, don't include core name in subroutines + sprintf(core_string, "_"); + + if(subpool){ + sprintf(pool_name, "%s_subpool", parentname); + } else { + sprintf(pool_name, "pool"); + } + + structname = ezxml_attr(superStruct, "name"); + structnameincode = ezxml_attr(superStruct, "name_in_code"); + + if(!structnameincode){ + structnameincode = ezxml_attr(superStruct, "name"); + } + + structpackages = ezxml_attr(superStruct, "packages"); + + // Extract all sub structs + for (struct_xml = ezxml_child(superStruct, "var_struct"); struct_xml; struct_xml = struct_xml->next){ + err = parse_struct(fd, registry, struct_xml, 1, structname, corename); + } + + fortprintf(fd, " subroutine mpas_generate%s%s_%s(block, structPool, dimensionPool, packagePool)\n", core_string, pool_name, structname); + fortprintf(fd, " type (block_type), intent(inout), pointer :: block\n"); + fortprintf(fd, " type (mpas_pool_type), intent(inout) :: structPool\n"); + fortprintf(fd, " type (mpas_pool_type), intent(inout) :: dimensionPool\n"); + fortprintf(fd, " type (mpas_pool_type), intent(in) :: packagePool\n"); + write_field_pointer_arrays(fd); + fortprintf(fd, " type (mpas_pool_type), pointer :: newSubPool\n"); + fortprintf(fd, " type (mpas_pool_iterator_type) :: dimItr\n"); + fortprintf(fd, " integer, pointer :: dim0D\n"); + fortprintf(fd, " integer, dimension(:), pointer :: dim1D\n"); + fortprintf(fd, " integer :: group_counter\n"); + fortprintf(fd, " logical :: group_started\n"); + fortprintf(fd, " integer :: group_start\n"); + fortprintf(fd, " integer :: index_counter\n"); + fortprintf(fd, " integer, pointer :: const_index\n"); + fortprintf(fd, "\n"); + + // Need to define logicals for all packages + for (packages_xml = ezxml_child(registry, "packages"); packages_xml; packages_xml = packages_xml->next){ + for (package_xml = ezxml_child(packages_xml, "package"); package_xml; package_xml = package_xml->next){ + packagename = ezxml_attr(package_xml, "name"); + + fortprintf(fd, " logical, pointer :: %sActive\n", packagename); + } + } + + fortprintf(fd, "\n"); + + // Need to define integers for all dimensions + for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ + for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ + dimname = ezxml_attr(dim_xml, "name"); + + fortprintf(fd, " integer, pointer :: %s\n", dimname); + } + } + + fortprintf(fd, "\n"); + fortprintf(fd, " integer :: numConstituents\n"); + fortprintf(fd, "\n"); + + fortprintf(fd, " nullify(newSubPool)\n"); + + fortprintf(fd, " group_counter = -1\n"); + fortprintf(fd, " group_started = .false.\n"); + fortprintf(fd, " group_start = -1\n"); + + // Need to get value of package flags + for (packages_xml = ezxml_child(registry, "packages"); packages_xml; packages_xml = packages_xml->next){ + for (package_xml = ezxml_child(packages_xml, "package"); package_xml; package_xml = package_xml->next){ + packagename = ezxml_attr(package_xml, "name"); + + fortprintf(fd, " call mpas_pool_get_package(packagePool, '%sActive', %sActive)\n", packagename, packagename); + } + } + + fortprintf(fd, "\n"); + + // Parse packages if they are defined + package_list[0] = '\0'; + no_packages = build_struct_package_lists(superStruct, package_list); + + spacing[0] = '\0'; + if(!no_packages){ + fortprintf(fd, " if ("); + string = strdup(package_list); + tofree = string; + token = strsep(&string, ";"); + fortprintf(fd, "%sActive", token); + + while( (token = strsep(&string, ";")) != NULL){ + fortprintf(fd, " .or. %sActive", token); + } + + fortprintf(fd, ") then\n"); + sprintf(spacing, " "); + } + + // Setup new pool to be added into structPool + fortprintf(fd, " %sallocate(newSubPool)\n", spacing); + fortprintf(fd, " %scall mpas_pool_create_pool(newSubPool)\n", spacing); + fortprintf(fd, " %scall mpas_pool_add_subpool(structPool, '%s', newSubPool)\n", spacing, structnameincode); + fortprintf(fd, " %scall mpas_pool_add_subpool(block %% allStructs, '%s', newSubPool)\n", spacing, structname); + + if(!no_packages){ + fortprintf(fd, " end if\n"); + } + + // Need to get value of dimensions + for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ + for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ + dimname = ezxml_attr(dim_xml, "name"); + + fortprintf(fd, " call mpas_pool_get_dimension(dimensionPool, '%s', %s)\n", dimname, dimname); + } + } + + fortprintf(fd, "\n"); + + // All sub-structs have been parsed and generated at this point. Time to generate this struct + // Start by generating variable arrays + for (var_arr_xml = ezxml_child(superStruct, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){ + parse_var_array(fd, registry, superStruct, var_arr_xml, corename); + } + + + // Define independent variables + for (var_xml = ezxml_child(superStruct, "var"); var_xml; var_xml = var_xml->next){ + parse_var(fd, registry, superStruct, var_xml, corename); + } + + fortprintf(fd, "\n"); + + // Extract all sub structs + for (struct_xml = ezxml_child(superStruct, "var_struct"); struct_xml; struct_xml = struct_xml->next){ + fortprintf(fd, " call mpas_generate%s%s_subpool_%s(block, newSubPool, dimensionPool, packagePool)\n", core_string, structname, substructname); + } + + fortprintf(fd, "\n"); + fortprintf(fd, " if (associated(newSubPool)) then\n"); + fortprintf(fd, " call mpas_pool_add_config(newSubPool, 'on_a_sphere', block %% domain %% on_a_sphere)\n"); + fortprintf(fd, " call mpas_pool_add_config(newSubPool, 'sphere_radius', block %% domain %% sphere_radius)\n"); + fortprintf(fd, " call mpas_pool_begin_iteration(dimensionPool)\n"); + fortprintf(fd, " do while( mpas_pool_get_next_member(dimensionPool, dimItr) )\n"); + fortprintf(fd, " if (dimItr %% memberType == MPAS_POOL_DIMENSION) then\n"); + fortprintf(fd, " if (dimItr %% nDims == 0) then\n"); + fortprintf(fd, " call mpas_pool_get_dimension(dimensionPool, dimItr %% memberName, dim0d)\n"); + fortprintf(fd, " call mpas_pool_add_dimension(newSubPool, dimItr %% memberName, dim0d)\n"); + fortprintf(fd, " else if (dimItr %% nDims == 1) then\n"); + fortprintf(fd, " call mpas_pool_get_dimension(dimensionPool, dimItr %% memberName, dim1d)\n"); + fortprintf(fd, " call mpas_pool_add_dimension(newSubPool, dimItr %% memberName, dim1d)\n"); + fortprintf(fd, " end if\n"); + fortprintf(fd, " end if\n"); + fortprintf(fd, " end do\n"); + fortprintf(fd, " end if\n"); + fortprintf(fd, "\n"); + + fortprintf(fd, " end subroutine mpas_generate%s%s_%s\n", core_string, pool_name, structname); + fortprintf(fd, "\n\n"); + + return 0; +}/*}}}*/ + + +int determine_struct_depth(int curLevel, ezxml_t superStruct){/*{{{*/ + ezxml_t subStruct; + int max_depth, depth; + + max_depth = curLevel; + + for(subStruct = ezxml_child(superStruct, "var_struct"); subStruct; subStruct = subStruct->next){ + depth = determine_struct_depth(curLevel+1, subStruct); + + if(depth > max_depth){ + max_depth = depth; + } + } + + return max_depth; +}/*}}}*/ + + +int generate_struct_links(FILE *fd, int curLevel, ezxml_t superStruct){/*{{{*/ + ezxml_t subStruct; + ezxml_t var_arr_xml, var_xml; + const char *structname; + const char *vartimelevs; + const char *varname, *vardims, *vartype; + const char *vardefaultval; + const char *varname_in_code; + int depth; + int err; + int has_time; + int time_lev, time_levs; + int ndims, type; + int decomp; + char *string, *tofree, *token; + char pointer_name[1024]; + char default_value[1024]; + + depth = curLevel + 1; + + for(subStruct = ezxml_child(superStruct, "var_struct"); subStruct; subStruct = subStruct->next){ + structname = ezxml_attr(subStruct, "name"); + fortprintf(fd, "! ----------- NEW STRUCT ---------\n"); + fortprintf(fd, "! Get pointers to pools for struct %s\n", structname); + fortprintf(fd, "! --------------------------------\n"); + if(curLevel == 0){ + fortprintf(fd, " call mpas_pool_get_subpool(currentBlock %% structs, '%s', poolLevel%d)\n", structname, curLevel+1); + fortprintf(fd, " if(associated(prevBlock)) then\n"); + fortprintf(fd, " call mpas_pool_get_subpool(prevBlock %% structs, '%s', prevPoolLevel%d)\n", structname, curLevel+1); + fortprintf(fd, " else\n"); + fortprintf(fd, " nullify(prevPoolLevel%d)\n", curLevel+1); + fortprintf(fd, " end if\n"); + fortprintf(fd, " if(associated(nextBlock)) then\n"); + fortprintf(fd, " call mpas_pool_get_subpool(nextBlock %% structs, '%s', nextPoolLevel%d)\n", structname, curLevel+1); + fortprintf(fd, " else\n"); + fortprintf(fd, " nullify(nextPoolLevel%d)\n", curLevel+1); + fortprintf(fd, " end if\n"); + } else { + fortprintf(fd, " call mpas_pool_get_subpool(poolLevel%d, '%s', poolLevel%d)\n", curLevel, structname, curLevel+1); + fortprintf(fd, " if(associated(prevBlock)) then\n"); + fortprintf(fd, " call mpas_pool_get_subpool(prevPoolLevel%d, '%s', prevPoolLevel%d)\n", curLevel, structname, curLevel+1); + fortprintf(fd, " else\n"); + fortprintf(fd, " nullify(prevPoolLevel%d)\n", curLevel+1); + fortprintf(fd, " end if\n"); + fortprintf(fd, " if(associated(nextBlock)) then\n"); + fortprintf(fd, " call mpas_pool_get_subpool(nextPoolLevel%d, '%s', nextPoolLevel%d)\n", curLevel, structname, curLevel+1); + fortprintf(fd, " else\n"); + fortprintf(fd, " nullify(nextPoolLevel%d)\n", curLevel+1); + fortprintf(fd, " end if\n"); + } + + fortprintf(fd, "\n"); + // Link var arrays + for(var_arr_xml = ezxml_child(subStruct, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){/*{{{*/ + varname = ezxml_attr(var_arr_xml, "name"); + vardims = ezxml_attr(var_arr_xml, "dimensions"); + vartimelevs = ezxml_attr(var_arr_xml, "time_levs"); + vartype = ezxml_attr(var_arr_xml, "type"); + vardefaultval = ezxml_attr(var_arr_xml, "default_value"); + + if(!vartimelevs){ + vartimelevs = ezxml_attr(subStruct, "time_levs"); + } + + if(vartimelevs){ + time_levs = atoi(vartimelevs); + if(time_levs < 1){ + time_levs = 1; + } + } else { + time_levs = 1; + } + + // Determine field type and default value. + get_field_information(vartype, vardefaultval, default_value, &type); + + // Determine number of dimensions + // and decomp type + get_dimension_information(vardims, &ndims, &has_time, &decomp); + ndims++; // Add a dimension for var_arrays + + // Using type and ndims, determine name of pointer for field. + set_pointer_name(type, ndims, pointer_name); + + for(time_lev = 1; time_lev <= time_levs; time_lev++){ + fortprintf(fd, "! Linking %s for time level %d\n", varname, time_lev); + fortprintf(fd, " call mpas_pool_get_field(poolLevel%d, '%s', %s, %d)\n", curLevel+1, varname, pointer_name, time_lev); + fortprintf(fd, " if(associated(%s)) then\n", pointer_name); + fortprintf(fd, "#ifdef MPAS_DEBUG\n"); + fortprintf(fd, " write(stderrUnit,*) 'Linking %s'\n", varname); + fortprintf(fd, "#endif\n"); + fortprintf(fd, " if(associated(prevBlock)) then\n"); + fortprintf(fd, " call mpas_pool_get_field(prevPoolLevel%d, '%s', %s %% prev, %d)\n", curLevel+1, varname, pointer_name, time_lev); + fortprintf(fd, " end if\n"); + fortprintf(fd, " if(associated(nextBlock)) then\n"); + fortprintf(fd, " call mpas_pool_get_field(nextPoolLevel%d, '%s', %s %% next, %d)\n", curLevel+1, varname, pointer_name, time_lev); + fortprintf(fd, " end if\n"); + + if(decomp == CELLS){ + fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% cellsToSend\n", pointer_name); + fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% cellsToRecv\n", pointer_name); + fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% cellsToCopy\n", pointer_name); + } else if(decomp == EDGES){ + fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% edgesToSend\n", pointer_name); + fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% edgesToRecv\n", pointer_name); + fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% edgesToCopy\n", pointer_name); + } else if(decomp == VERTICES){ + fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% verticesToSend\n", pointer_name); + fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% verticesToRecv\n", pointer_name); + fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% verticesToCopy\n", pointer_name); + } + + fortprintf(fd, " end if\n"); + } + + fortprintf(fd, "\n"); + }/*}}}*/ + + // Link independent vars + for(var_xml = ezxml_child(subStruct, "var"); var_xml; var_xml = var_xml->next){/*{{{*/ + varname = ezxml_attr(var_xml, "name"); + vardims = ezxml_attr(var_xml, "dimensions"); + vartimelevs = ezxml_attr(var_xml, "time_levs"); + vartype = ezxml_attr(var_xml, "type"); + vardefaultval = ezxml_attr(var_xml, "default_value"); + varname_in_code = ezxml_attr(var_xml, "name_in_code"); + + if(!vartimelevs){ + vartimelevs = ezxml_attr(subStruct, "time_levs"); + } + + if(vartimelevs){ + time_levs = atoi(vartimelevs); + if(time_levs < 1){ + time_levs = 1; + } + } else { + time_levs = 1; + } + + if(!varname_in_code){ + varname_in_code = ezxml_attr(var_xml, "name"); + } + + // Determine field type and default value. + get_field_information(vartype, vardefaultval, default_value, &type); + + // Determine number of dimensions + // and decomp type + get_dimension_information(vardims, &ndims, &has_time, &decomp); + + // Using type and ndims, determine name of pointer for field. + set_pointer_name(type, ndims, pointer_name); + + for(time_lev = 1; time_lev <= time_levs; time_lev++){ + fortprintf(fd, "! Linking %s for time level %d with name\n", varname, time_lev, varname_in_code); + fortprintf(fd, "#ifdef MPAS_DEBUG\n"); + fortprintf(fd, " write(stderrUnit,*) 'Linking %s with name %s'\n", varname, varname_in_code); + fortprintf(fd, "#endif\n"); + fortprintf(fd, " call mpas_pool_get_field(poolLevel%d, '%s', %s, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); + fortprintf(fd, " if(associated(%s)) then\n", pointer_name); + fortprintf(fd, " if(associated(prevBlock)) then\n"); + fortprintf(fd, " call mpas_pool_get_field(prevPoolLevel%d, '%s', %s %% prev, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); + fortprintf(fd, " end if\n"); + fortprintf(fd, " if(associated(nextBlock)) then\n"); + fortprintf(fd, " call mpas_pool_get_field(nextPoolLevel%d, '%s', %s %% next, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); + fortprintf(fd, " end if\n"); + + if(decomp == CELLS){ + fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% cellsToSend\n", pointer_name); + fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% cellsToRecv\n", pointer_name); + fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% cellsToCopy\n", pointer_name); + } else if(decomp == EDGES){ + fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% edgesToSend\n", pointer_name); + fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% edgesToRecv\n", pointer_name); + fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% edgesToCopy\n", pointer_name); + } else if(decomp == VERTICES){ + fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% verticesToSend\n", pointer_name); + fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% verticesToRecv\n", pointer_name); + fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% verticesToCopy\n", pointer_name); + } + fortprintf(fd, " end if\n"); + + fortprintf(fd, "\n"); + } + }/*}}}*/ + + err = generate_struct_links(fd, curLevel+1, subStruct); + } + + return 0; +}/*}}}*/ + + +int generate_field_links(ezxml_t registry){/*{{{*/ + ezxml_t struct_xml; + const char *corename; + FILE *fd; + int i, structDepth, err; + + char core_string[1024]; + + structDepth = determine_struct_depth(0, registry); + + corename = ezxml_attr(registry, "core"); + + sprintf(core_string, "_%s_", corename); + + // For now, don't include core name in subroutines + sprintf(core_string, "_"); + + fd = fopen("link_fields.inc", "w+"); + + fortprintf(fd, " subroutine mpas%slink_fields(domain)\n", core_string); + fortprintf(fd, " type (domain_type), intent(in) :: domain\n"); + fortprintf(fd, "\n"); + fortprintf(fd, " type (block_type), pointer :: blockPtr\n"); + fortprintf(fd, " type (block_type), pointer :: prevBlock\n"); + fortprintf(fd, " type (block_type), pointer :: nextBlock\n"); + fortprintf(fd, "\n"); + fortprintf(fd, " blockPtr => domain %% blocklist\n"); + fortprintf(fd, " do while(associated(blockPtr))\n"); + fortprintf(fd, " if (associated(blockPtr %% prev)) then\n"); + fortprintf(fd, " prevBlock => blockPtr %% prev\n"); + fortprintf(fd, " else\n"); + fortprintf(fd, " nullify(prevBlock)\n"); + fortprintf(fd, " end if\n"); + fortprintf(fd, "\n"); + fortprintf(fd, " if (associated(blockPtr %% next)) then\n"); + fortprintf(fd, " nextBlock => blockPtr %% next\n"); + fortprintf(fd, " else\n"); + fortprintf(fd, " nullify(nextBlock)\n"); + fortprintf(fd, " end if\n"); + fortprintf(fd, "\n"); + fortprintf(fd, " call mpas%slink_blocks(blockPtr, prevBlock, nextBlock)\n", core_string); + fortprintf(fd, "\n"); + fortprintf(fd, " blockPtr => blockPtr %% next\n"); + fortprintf(fd, " end do\n"); + fortprintf(fd, "\n"); + fortprintf(fd, " end subroutine mpas%slink_fields\n", core_string); + fortprintf(fd, "\n"); + fortprintf(fd, "\n"); + fortprintf(fd, " subroutine mpas%slink_blocks(currentBlock, prevBlock, nextBlock)\n", core_string); + fortprintf(fd, " type (block_type), pointer, intent(in) :: currentBlock\n"); + fortprintf(fd, " type (block_type), pointer, intent(in) :: prevBlock\n"); + fortprintf(fd, " type (block_type), pointer, intent(in) :: nextBlock\n"); + write_field_pointers(fd); + for(i = 1; i <= structDepth; i++){ + fortprintf(fd, " type (mpas_pool_type), pointer :: poolLevel%d\n", i); + fortprintf(fd, " type (mpas_pool_type), pointer :: prevPoolLevel%d\n", i); + fortprintf(fd, " type (mpas_pool_type), pointer :: nextPoolLevel%d\n", i); + } + fortprintf(fd, "\n"); + + err = generate_struct_links(fd, 0, registry); + + fortprintf(fd, " end subroutine mpas%slink_blocks\n", core_string); + + fclose(fd); + + return 0; +}/*}}}*/ + + +int generate_immutable_struct_contents(FILE *fd, const char *streamname, ezxml_t varstruct_xml){/*{{{*/ + ezxml_t var_xml, vararr_xml, substruct_xml; + + const char *optname, *optstream; + + /* Loop over fields looking for any that belong to the stream */ + for (vararr_xml = ezxml_child(varstruct_xml, "var"); vararr_xml; vararr_xml = vararr_xml->next) { + optstream = ezxml_attr(vararr_xml, "streams"); + if (optstream != NULL && strstr(optstream, streamname) != NULL) { + optname = ezxml_attr(vararr_xml, "name"); + fortprintf(fd, " call MPAS_stream_mgr_add_field(manager, \'%s\', \'%s\', ierr=ierr)\n", streamname, optname); + } + } + + for (var_xml = ezxml_child(varstruct_xml, "var"); var_xml; var_xml = var_xml->next) { + optstream = ezxml_attr(var_xml, "streams"); + if (optstream != NULL && strstr(optstream, streamname) != NULL) { + optname = ezxml_attr(var_xml, "name"); + fortprintf(fd, " call MPAS_stream_mgr_add_field(manager, \'%s\', \'%s\', ierr=ierr)\n", streamname, optname); + } + } + + for (substruct_xml = ezxml_child(varstruct_xml, "var_struct"); substruct_xml; substruct_xml = substruct_xml->next){ + generate_immutable_struct_contents(fd, streamname, substruct_xml); + } + + return 0; +}/*}}}*/ + + +/********************************************************************************* + * + * Function: generate_immutable_streams + * + * Generates the Fortran include file 'setup_immutable_streams.inc' that contains + * the subroutine mpas_generate_immutable_streams() responsible for making calls + * to the stream manager to define all immutable streams. + * The mpas_generate_immutable_streams() routine should be called after blocks + * have been allocated in the framework and after the stream manager has been + * initialized, but before any calls to generate mutable streams are made. + * + *********************************************************************************/ +int generate_immutable_streams(ezxml_t registry){/*{{{*/ + ezxml_t streams_xml, stream_xml, var_xml, vararr_xml, varstruct_xml; + ezxml_t substream_xml, matchstreams_xml, matchstream_xml; + + const char *optname, *opttype, *optvarname, *optstream, *optfilename, *optinterval_in, *optinterval_out, *optimmutable; + const char *optstructname, *optsubstreamname, *optmatchstreamname, *optmatchimmutable; + const char *corename; + FILE *fd; + + char core_string[1024]; + + corename = ezxml_attr(registry, "core"); + + sprintf(core_string, "_%s_", corename); + + // For now, don't include core name in subroutines + sprintf(core_string, "_"); + + fd = fopen("setup_immutable_streams.inc", "w+"); + + fprintf(stderr, "---- GENERATING IMMUTABLE STREAMS ----\n"); + + fortprintf(fd, "subroutine mpas%ssetup_immutable_streams(manager)\n\n", core_string); + fortprintf(fd, " use MPAS_stream_manager, only : MPAS_streamManager_type, MPAS_STREAM_INPUT_OUTPUT, MPAS_STREAM_INPUT, &\n"); + fortprintf(fd, " MPAS_STREAM_OUTPUT, MPAS_STREAM_NONE, MPAS_STREAM_PROPERTY_IMMUTABLE, &\n"); + fortprintf(fd, " MPAS_stream_mgr_create_stream, MPAS_stream_mgr_add_field, MPAS_stream_mgr_set_property\n\n"); + fortprintf(fd, " implicit none\n\n"); + fortprintf(fd, " type (MPAS_streamManager_type), pointer :: manager\n\n"); + fortprintf(fd, " integer :: ierr\n\n"); + + for (streams_xml = ezxml_child(registry, "streams"); streams_xml; streams_xml = streams_xml->next) { + for (stream_xml = ezxml_child(streams_xml, "stream"); stream_xml; stream_xml = stream_xml->next) { + + optimmutable = ezxml_attr(stream_xml, "immutable"); + + if (optimmutable != NULL && strcmp(optimmutable, "true") == 0) { + + optname = ezxml_attr(stream_xml, "name"); + opttype = ezxml_attr(stream_xml, "type"); + optfilename = ezxml_attr(stream_xml, "filename_template"); + + /* create the stream */ + if (strstr(opttype, "input") != NULL && strstr(opttype, "output") != NULL) + fortprintf(fd, " call MPAS_stream_mgr_create_stream(manager, \'%s\', MPAS_STREAM_INPUT_OUTPUT, \'%s\', ierr=ierr)\n", optname, optfilename); + else if (strstr(opttype, "input") != NULL) + fortprintf(fd, " call MPAS_stream_mgr_create_stream(manager, \'%s\', MPAS_STREAM_INPUT, \'%s\', ierr=ierr)\n", optname, optfilename); + else if (strstr(opttype, "output") != NULL) + fortprintf(fd, " call MPAS_stream_mgr_create_stream(manager, \'%s\', MPAS_STREAM_OUTPUT, \'%s\', ierr=ierr)\n", optname, optfilename); + else + fortprintf(fd, " call MPAS_stream_mgr_create_stream(manager, \'%s\', MPAS_STREAM_NONE, \'%s\', ierr=ierr)\n", optname, optfilename); + + /* Loop over streams listed within the stream (only use immutable streams) */ + for (substream_xml = ezxml_child(stream_xml, "stream"); substream_xml; substream_xml = ezxml_next(substream_xml)) { + optsubstreamname = ezxml_attr(substream_xml, "name"); + + /* Find stream definition with matching name */ + for (matchstreams_xml = ezxml_child(registry, "streams"); matchstreams_xml; matchstreams_xml = matchstreams_xml->next){ + for (matchstream_xml = ezxml_child(matchstreams_xml, "stream"); matchstream_xml; matchstream_xml = matchstream_xml->next){ + optmatchstreamname = ezxml_attr(matchstream_xml, "name"); + optmatchimmutable = ezxml_attr(matchstream_xml, "immutable"); + + if (optmatchstreamname != NULL && strcmp(optmatchstreamname, optsubstreamname) == 0){ + if (optmatchimmutable != NULL && strcmp(optmatchimmutable, "true") == 0) { + /* Loop over fields listed within the stream */ + for (var_xml = ezxml_child(matchstream_xml, "var"); var_xml; var_xml = var_xml->next) { + optvarname = ezxml_attr(var_xml, "name"); + fortprintf(fd, " call MPAS_stream_mgr_add_field(manager, \'%s\', \'%s\', ierr=ierr)\n", optname, optvarname); + } + + /* Loop over arrays of fields listed within the stream */ + for (vararr_xml = ezxml_child(matchstream_xml, "var_array"); vararr_xml; vararr_xml = vararr_xml->next) { + optvarname = ezxml_attr(vararr_xml, "name"); + fortprintf(fd, " call MPAS_stream_mgr_add_field(manager, \'%s\', \'%s\', ierr=ierr)\n", optname, optvarname); + } + + /* Loop over var structs listed within the stream */ + for (varstruct_xml = ezxml_child(matchstream_xml, "var_struct"); varstruct_xml; varstruct_xml = varstruct_xml->next) { + optstructname = ezxml_attr(varstruct_xml, "name"); + fortprintf(fd, " call MPAS_stream_mgr_add_pool(manager, \'%s\', \'%s\', ierr=ierr)\n", optname, optstructname); + } + + } else { + printf("ERROR: Immutable streams cannot contain mutable streams within them.\n"); + printf("ERROR: Immutable stream \'%s\' contains a mutable stream \'%s\'.\n", optname, optsubstreamname); + return 1; + } + } + } + } + } + + /* Loop over var structs listed within the stream */ + for (varstruct_xml = ezxml_child(stream_xml, "var_struct"); varstruct_xml; varstruct_xml = ezxml_next(varstruct_xml)) { + optstructname = ezxml_attr(varstruct_xml, "name"); + fortprintf(fd, " call MPAS_stream_mgr_add_pool(manager, \'%s\', \'%s\', ierr=ierr)\n", optname, optstructname); + } + + + /* Loop over arrays of fields listed within the stream */ + for (vararr_xml = ezxml_child(stream_xml, "var_array"); vararr_xml; vararr_xml = ezxml_next(vararr_xml)) { + optvarname = ezxml_attr(vararr_xml, "name"); + fortprintf(fd, " call MPAS_stream_mgr_add_field(manager, \'%s\', \'%s\', ierr=ierr)\n", optname, optvarname); + } + + /* Loop over fields listed within the stream */ + for (var_xml = ezxml_child(stream_xml, "var"); var_xml; var_xml = ezxml_next(var_xml)) { + optvarname = ezxml_attr(var_xml, "name"); + fortprintf(fd, " call MPAS_stream_mgr_add_field(manager, \'%s\', \'%s\', ierr=ierr)\n", optname, optvarname); + } + + /* Loop over fields looking for any that belong to the stream */ + for (varstruct_xml = ezxml_child(registry, "var_struct"); varstruct_xml; varstruct_xml = ezxml_next(varstruct_xml)) { + generate_immutable_struct_contents(fd, optname, varstruct_xml); + } + + fortprintf(fd, " call MPAS_stream_mgr_set_property(manager, \'%s\', MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=ierr)\n\n", optname); + } + + } + } + + fortprintf(fd, "end subroutine mpas%ssetup_immutable_streams\n", core_string); + + fclose(fd); + + return 0; +}/*}}}*/ + + +int push_attributes(ezxml_t currentPosition){/*{{{*/ + ezxml_t child_xml, child_xml2; + ezxml_t childStruct1, childStruct2, lastStruct; + + const char *name, *name2; + const char *subname; + const char *super_time_levs, *super_packages; + const char *sub_time_levs, *sub_packages; + + int skip_struct; + + name = ezxml_attr(currentPosition, "name"); + + // Iterate over var_arrays + for(child_xml = ezxml_child(currentPosition, "var_array"); child_xml; child_xml = child_xml->next){ + super_time_levs = ezxml_attr(currentPosition, "time_levs"); + super_packages = ezxml_attr(currentPosition, "packages"); + subname = ezxml_attr(child_xml, "name"); + sub_time_levs = ezxml_attr(child_xml, "time_levs"); + sub_packages = ezxml_attr(child_xml, "packages"); + + if(!sub_time_levs && super_time_levs){ + child_xml = ezxml_set_attr(child_xml, "time_levs", super_time_levs); + } + + if(!sub_packages && super_packages){ + child_xml = ezxml_set_attr(child_xml, "packages", super_packages); + } + + // Iterate over vars in var_array + for(child_xml2 = ezxml_child(child_xml, "var"); child_xml2; child_xml2 = child_xml2->next){ + super_packages = ezxml_attr(child_xml, "packages"); + sub_packages = ezxml_attr(child_xml2, "packages"); + + if(!sub_packages && super_packages){ + child_xml2 = ezxml_set_attr(child_xml2, "packages", super_packages); + } + } + } + + // Iterate over vars + for(child_xml = ezxml_child(currentPosition, "var"); child_xml; child_xml = child_xml->next){ + super_packages = ezxml_attr(currentPosition, "packages"); + super_time_levs = ezxml_attr(currentPosition, "time_levs"); + subname = ezxml_attr(child_xml, "name"); + sub_time_levs = ezxml_attr(child_xml, "time_levs"); + sub_packages = ezxml_attr(child_xml, "packages"); + + if(!sub_time_levs && super_time_levs){ + child_xml = ezxml_set_attr(child_xml, "time_levs", super_time_levs); + } + + if(!sub_packages && super_packages){ + child_xml = ezxml_set_attr(child_xml, "packages", super_packages); + } + } + + // Iterate over var structs + for(child_xml = ezxml_child(currentPosition, "var_struct"); child_xml; child_xml = child_xml->next){ + super_packages = ezxml_attr(currentPosition, "packages"); + super_time_levs = ezxml_attr(currentPosition, "time_levs"); + + subname = ezxml_attr(child_xml, "name"); + sub_time_levs = ezxml_attr(child_xml, "time_levs"); + sub_packages = ezxml_attr(child_xml, "packages"); + + if(!sub_time_levs && super_time_levs){ + child_xml = ezxml_set_attr(child_xml, "time_levs", super_time_levs); + } + + if(!sub_packages && super_packages){ + child_xml = ezxml_set_attr(child_xml, "packages", super_packages); + } + + push_attributes(child_xml); + } + + return 0; +}/*}}}*/ + + +int merge_structs_and_var_arrays(ezxml_t currentPosition){/*{{{*/ + ezxml_t old_child, new_child; + ezxml_t childStruct1, childStruct2, lastStruct; + + const char *name, *name2; + const char *subname; + + int skip_struct; + + // Merge var_structs + for(childStruct1 = ezxml_child(currentPosition, "var_struct"); childStruct1; childStruct1 = childStruct1->next){ + name = ezxml_attr(childStruct1, "name"); + + skip_struct = 0; + for(childStruct2 = ezxml_child(currentPosition, "var_struct"); childStruct2 != childStruct1 && childStruct2; childStruct2 = childStruct2->next){ + name2 = ezxml_attr(childStruct2, "name"); + + if(strcmp(name, name2) == 0){ + skip_struct = 1; + } + } + + if(!skip_struct && childStruct1->next){ + lastStruct = childStruct1; + for(childStruct2 = childStruct1->next; childStruct2; childStruct2 = childStruct2->next){ + name2 = ezxml_attr(childStruct2, "name"); + + if(strcmp(name, name2) == 0){ + // Merge children into childStruct1, and "remove" childStruct2 + for(old_child = ezxml_child(childStruct2, "var"); old_child; old_child = old_child->next){ + new_child = ezxml_insert(old_child, childStruct1, strlen(childStruct1->txt)); + } + + for(old_child = ezxml_child(childStruct2, "var_array"); old_child; old_child = old_child->next){ + new_child = ezxml_insert(old_child, childStruct1, strlen(childStruct1->txt)); + } + + for(old_child = ezxml_child(childStruct2, "var_struct"); old_child; old_child = old_child->next){ + new_child = ezxml_insert(old_child, childStruct1, strlen(childStruct1->txt)); + } + + // Remove childStruct2 + lastStruct->next = childStruct2->next; + free(childStruct2); + childStruct2 = lastStruct; + } else { + lastStruct = childStruct2; + } + } + } + } + + // Merge var_arrays + for(childStruct1 = ezxml_child(currentPosition, "var_array"); childStruct1; childStruct1 = childStruct1->next){ + name = ezxml_attr(childStruct1, "name"); + + skip_struct = 0; + for(childStruct2 = ezxml_child(currentPosition, "var_array"); childStruct2 && childStruct2 != childStruct1; childStruct2 = childStruct2->next){ + name2 = ezxml_attr(childStruct2, "name"); + + if(strcmp(name, name2) == 0){ + skip_struct = 1; + } + } + + if(!skip_struct && childStruct1->next){ + lastStruct = childStruct1; + for(childStruct2 = childStruct1->next; childStruct2; childStruct2 = childStruct2->next){ + name2 = ezxml_attr(childStruct2, "name"); + + if(strcmp(name, name2) == 0){ + // Merge var_arrays and remove childStruct2 + for(old_child = ezxml_child(childStruct2, "var"); old_child; old_child = old_child->next){ + new_child = ezxml_insert(old_child, childStruct1, strlen(childStruct1->txt)); + } + + lastStruct->next = childStruct2->next; + free(childStruct2); + childStruct2 = lastStruct; + } else { + lastStruct = childStruct2; + } + } + } + } + + for(childStruct1 = ezxml_child(currentPosition, "var_struct"); childStruct1; childStruct1 = childStruct1->next){ + merge_structs_and_var_arrays(childStruct1); + } + + return 0; +}/*}}}*/ + + +int merge_streams(ezxml_t registry){/*{{{*/ + ezxml_t old_child, new_child, tmp_child; + ezxml_t childStream1, childStream2, lastStream; + ezxml_t includeStream; + + ezxml_t streamsBlock, streamsBlock2; + + const char *name, *name2; + const char *subname; + + int skip_stream; + + // First, merge all streams blocks. Regardless of nested stream names. + streamsBlock = ezxml_child(registry, "streams"); + while(streamsBlock->next){ + for(childStream1 = ezxml_child(streamsBlock->next, "stream"); childStream1; childStream1){ + if (childStream1->next){ + lastStream = childStream1->next; + } else { + lastStream = NULL; + } + name = ezxml_attr(childStream1, "name"); + new_child = ezxml_insert(childStream1, streamsBlock, strlen(streamsBlock->txt)); + + childStream1 = lastStream; + + } + + lastStream = streamsBlock->next; + streamsBlock->next = streamsBlock->next->next; + free(lastStream); + } + + + // Now, merge all streams with the same name, within streamsBlock + streamsBlock = ezxml_child(registry, "streams"); + for(childStream1 = ezxml_child(streamsBlock, "stream"); childStream1; childStream1 = childStream1->next){ + name = ezxml_attr(childStream1, "name"); + + skip_stream = 0; + + for(childStream2 = ezxml_child(streamsBlock, "stream"); childStream2 && childStream2 != childStream1; childStream2 = childStream2->next){ + name2 = ezxml_attr(childStream2, "name"); + + if(strcmp(name, name2) == 0){ + skip_stream = 1; + } + } + + if(!skip_stream && childStream1->next){ + lastStream = childStream1; + for(childStream2 = childStream1->next; childStream2; childStream2 = childStream2->next){ + name2 = ezxml_attr(childStream2, "name"); + + if(strcmp(name, name2) == 0){ + // Merge child vars + for(old_child = ezxml_child(childStream2, "var"); old_child; old_child){ + if(old_child->next){ + tmp_child = old_child->next; + } else { + tmp_child = NULL; + } + new_child = ezxml_insert(old_child, childStream1, strlen(childStream1->txt)); + + old_child = tmp_child; + } + + for(old_child = ezxml_child(childStream2, "var_array"); old_child; old_child){ + if(old_child->next){ + tmp_child = old_child->next; + } else { + tmp_child = NULL; + } + new_child = ezxml_insert(old_child, childStream1, strlen(childStream1->txt)); + + old_child = tmp_child; + } + + for(old_child = ezxml_child(childStream2, "var_struct"); old_child; old_child){ + if(old_child->next){ + tmp_child = old_child->next; + } else { + tmp_child = NULL; + } + new_child = ezxml_insert(old_child, childStream1, strlen(childStream1->txt)); + + old_child = tmp_child; + } + + for(old_child = ezxml_child(childStream2, "stream"); old_child; old_child){ + if(old_child->next){ + tmp_child = old_child->next; + } else { + tmp_child = NULL; + } + new_child = ezxml_insert(old_child, childStream1, strlen(childStream1->txt)); + + old_child = tmp_child; + } + + + + + lastStream->next = childStream2->next; + free(childStream2); + childStream2 = lastStream; + } else { + lastStream = childStream2; + } + } + } + } + + return 0; +}/*}}}*/ + + +int parse_structs_from_registry(ezxml_t registry)/*{{{*/ +{ + ezxml_t structs_xml, var_arr_xml, var_xml; + ezxml_t packages_xml, package_xml; + + const char *corename, *packagename, *structname, *structpackages; + FILE *fd; + int err; + + char core_string[1024]; + char spacing[1024]; + char package_list[2048]; + + int no_packages; + + char *string, *tofree, *token; + + corename = ezxml_attr(registry, "core"); + + sprintf(core_string, "_%s_", corename); + + // For now, don't include core name in subroutines. + sprintf(core_string, "_"); + + fd = fopen("structs_and_variables.inc", "w+"); + + for (structs_xml = ezxml_child(registry, "var_struct"); structs_xml; structs_xml = structs_xml->next){ + err = parse_struct(fd, registry, structs_xml, 0, '\0', corename); + } + + fortprintf(fd, " subroutine mpas_generate_structs(block, structPool, dimensionPool, packagePool)\n"); + fortprintf(fd, " type (block_type), pointer, intent(inout) :: block\n"); + fortprintf(fd, " type (mpas_pool_type), intent(inout) :: structPool\n"); + fortprintf(fd, " type (mpas_pool_type), intent(inout) :: dimensionPool\n"); + fortprintf(fd, " type (mpas_pool_type), intent(in) :: packagePool\n"); + + fortprintf(fd, "\n"); + + for (structs_xml = ezxml_child(registry, "var_struct"); structs_xml; structs_xml = structs_xml->next){ + structname = ezxml_attr(structs_xml, "name"); + + fortprintf(fd, " call mpas_generate%spool_%s(block, structPool, dimensionPool, packagePool)\n", core_string, structname); + + fortprintf(fd, "\n"); + } + + + fortprintf(fd, " end subroutine mpas_generate_structs\n"); + + fclose(fd); + + return 0; +}/*}}}*/ -void gen_writes(struct group_list * groups, struct variable * vars, struct dimension * dims, struct namelist * namelists) -{ - struct variable * var_ptr; - struct variable_list * var_list_ptr, *var_list_ptr2; - struct dimension * dim_ptr; - struct dimension_list * dimlist_ptr, * lastdim; - struct group_list * group_ptr; - struct dtable * dictionary; - struct namelist * nl; - FILE * fd; - char vtype[5]; - char fname[32]; - char struct_deref[1024]; - char var_array[1024]; - char * cp1, * cp2; - int i, j; - int ivtype; - - - fd = fopen("add_output_fields.inc", "w"); - - group_ptr = groups; - while (group_ptr) { - var_list_ptr = group_ptr->vlist; - while (var_list_ptr) { - var_ptr = var_list_ptr->var; - - if (group_ptr->ntime_levs > 1) - snprintf(struct_deref, 1024, "domain %% blocklist %% %s %% time_levs(1) %% %s", group_ptr->name, group_ptr->name); - else - snprintf(struct_deref, 1024, "domain %% blocklist %% %s", group_ptr->name); - - if (strncmp(var_ptr->var_array, "-", 1024) != 0) { - fortprintf(fd, " if ((%s %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &\n", struct_deref, var_ptr->var_array); - fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART) .or. &\n", struct_deref, var_ptr->var_array); - fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. output_obj %% stream == SFC)) then\n", struct_deref, var_ptr->var_array); - memcpy(var_array, var_ptr->var_array, 1024); - fortprintf(fd, " call MPAS_streamAddField(output_obj %% io_stream, %s %% %s, ierr)\n", struct_deref, var_array); - while (var_list_ptr && strncmp(var_array, var_list_ptr->var->var_array, 1024) == 0) { - var_list_ptr2 = var_list_ptr; - var_list_ptr = var_list_ptr->next; - } - var_list_ptr = var_list_ptr2; - } - else { - fortprintf(fd, " if ((%s %% %s %% ioinfo %% output .and. output_obj %% stream == OUTPUT) .or. &\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd, " (%s %% %s %% ioinfo %% restart .and. output_obj %% stream == RESTART) .or. &\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd, " (%s %% %s %% ioinfo %% sfc .and. output_obj %% stream == SFC)) then\n", struct_deref, var_ptr->name_in_code); - fortprintf(fd, " call MPAS_streamAddField(output_obj %% io_stream, %s %% %s, ierr)\n", struct_deref, var_ptr->name_in_code); - } - - fortprintf(fd, " end if\n\n"); - - if (var_list_ptr) var_list_ptr = var_list_ptr->next; - } - group_ptr = group_ptr->next; - } - - fclose(fd); - - - fd = fopen("add_output_atts.inc", "w"); - - nl = namelists; - while (nl) { - if (nl->vtype == LOGICAL) { - fortprintf(fd, " if (%s) then\n", nl->name); - fortprintf(fd, " call MPAS_writeStreamAtt(output_obj %% io_stream, \'%s\', 'T', ierr)\n", nl->name); - fortprintf(fd, " else\n"); - fortprintf(fd, " call MPAS_writeStreamAtt(output_obj %% io_stream, \'%s\', 'F', ierr)\n", nl->name); - fortprintf(fd, " end if\n"); - } - else { - fortprintf(fd, " call MPAS_writeStreamAtt(output_obj %% io_stream, \'%s\', %s, ierr)\n", nl->name, nl->name); - } - nl = nl->next; - } - - fclose(fd); - -} diff --git a/src/registry/gen_inc.h b/src/registry/gen_inc.h index 10e7a5ade8..aedc06993c 100644 --- a/src/registry/gen_inc.h +++ b/src/registry/gen_inc.h @@ -5,9 +5,36 @@ // Additional copyright and license information can be found in the LICENSE file // distributed with this code, or at http://mpas-dev.github.com/license.html // -void gen_namelists(struct namelist *); -void gen_history_attributes(char * modelname, char * corename, char * version); -void gen_field_defs(struct group_list * groups, struct variable *, struct dimension *); -void gen_reads(struct group_list * groups, struct variable *, struct dimension *); -void gen_writes(struct group_list * groups, struct variable *, struct dimension *, struct namelist *); -void gen_packages(struct package * pkgs); +// + +#include "ezxml/ezxml.h" + +void write_model_variables(ezxml_t registry); +int write_field_pointers(FILE* fd); +int write_field_pointer_arrays(FILE* fd); +int set_pointer_name(int type, int ndims, char *pointer_name); +int add_package_to_list(const char * package, const char * package_list); +int build_struct_package_lists(ezxml_t currentPosition, char * out_packages); +int get_dimension_information(const char *dims, int *ndims, int *has_time, int *decomp); +int get_field_information(const char *vartype, const char *varval, char *default_value, int *type); +int write_set_field_pointer(FILE *fd, const char *spacing, const char *iterator_name, const char *pool_name); +void write_default_namelist(ezxml_t registry); +int parse_packages_from_registry(ezxml_t registry); +int parse_namelist_records_from_registry(ezxml_t registry); +int parse_dimensions_from_registry(ezxml_t registry); +int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t varArray, const char * corename); +int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVar, const char * corename); +int parse_struct(FILE *fd, ezxml_t registry, ezxml_t superStruct, int subpool, const char *parentname, const char * corename); +int determine_struct_depth(int curLevel, ezxml_t superStruct); +int generate_struct_links(FILE *fd, int curLevel, ezxml_t superStruct); +int generate_field_links(ezxml_t registry); +int generate_field_exchanges(FILE *fd, int curLevel, ezxml_t superStruct); +int generate_field_halo_exchanges_and_copies(ezxml_t registry); +int generate_field_inputs(FILE *fd, int curLevel, ezxml_t superStruct); +int generate_field_outputs(FILE *fd, int curLevel, ezxml_t superStruct); +int generate_field_reads_and_writes(ezxml_t registry); +int push_attributes(ezxml_t currentPosition); +int merge_structs_and_var_arrays(ezxml_t currentPosition); +int merge_streams(ezxml_t registry); +int parse_structs_from_registry(ezxml_t registry); + diff --git a/src/registry/parse.c b/src/registry/parse.c index f1fd6de69e..ca5db2519e 100644 --- a/src/registry/parse.c +++ b/src/registry/parse.c @@ -8,91 +8,92 @@ #include #include #include +#include "fortprintf.h" #include "registry_types.h" #include "gen_inc.h" #include "ezxml/ezxml.h" +#include "utility.h" -int getword(FILE *, char *); + +int is_unique_field(ezxml_t registry, ezxml_t field, const char *check_name); +int is_unique_struct(ezxml_t registry, ezxml_t check_struct, const char *check_name); +int check_for_unique_names(ezxml_t registry, ezxml_t current_position); int is_integer_constant(char *); -void sort_vars(struct variable *); -void sort_group_vars(struct group_list *); -int parse_reg_xml(ezxml_t registry, struct namelist **nls, struct dimension ** dims, struct variable ** vars, struct group_list ** groups, struct package ** pkgs, char * modelname, char * corename, char * version); +int parse_reg_xml(ezxml_t registry); int validate_reg_xml(ezxml_t registry); -char * check_packages(ezxml_t registry, char * dims); -char * check_dimensions(ezxml_t registry, char * dims); -char * check_streams(char * streams); -int check_persistence(const char * persistence); -int main(int argc, char ** argv) + +int main(int argc, char ** argv)/*{{{*/ { - FILE * regfile; - struct namelist * nls; - struct dimension * dims; - struct variable * vars; - struct group_list * groups; - struct package * pkgs; - - char *modelname, *corename, *version; - - modelname = (char *)malloc(sizeof(char)*1024); - corename = (char *)malloc(sizeof(char)*1024); - version = (char *)malloc(sizeof(char)*1024); - - if (argc != 2) { - fprintf(stderr,"Reading registry file from standard input\n"); - regfile = stdin; - } - else if (!(regfile = fopen(argv[1], "r"))) { - fprintf(stderr,"\nError: Could not open file %s for reading.\n\n", argv[1]); - return 1; - } - - nls = NULL; - dims = NULL; - vars = NULL; - - ezxml_t registry = ezxml_parse_fp(regfile); - - if (validate_reg_xml(registry)) { - fprintf(stderr, "Validation failed.....\n"); - return 1; - } - - if (parse_reg_xml(registry, &nls, &dims, &vars, &groups, &pkgs, modelname, corename, version)) { - fprintf(stderr, "Parsing failed.....\n"); - return 1; - } - - sort_vars(vars); - sort_group_vars(groups); - - gen_history_attributes(modelname, corename, version); - gen_namelists(nls); - gen_field_defs(groups, vars, dims); - gen_reads(groups, vars, dims); - gen_writes(groups, vars, dims, nls); - gen_packages(pkgs); - - free(modelname); - free(corename); - free(version); - - return 0; -} - -int validate_reg_xml(ezxml_t registry) + FILE * regfile; + struct namelist * nls; + struct dimension * dims; + struct variable * vars; + struct group_list * groups; + struct package * pkgs; + int err; + + if (argc != 2) { + fprintf(stderr,"Reading registry file from standard input\n"); + regfile = stdin; + } + else if (!(regfile = fopen(argv[1], "r"))) { + fprintf(stderr,"\nError: Could not open file %s for reading.\n\n", argv[1]); + return 1; + } + + nls = NULL; + dims = NULL; + vars = NULL; + + ezxml_t registry = ezxml_parse_fp(regfile); + + // Cleanup registry structures + err = push_attributes(registry); + err = merge_structs_and_var_arrays(registry); + err = merge_streams(registry); + + if (validate_reg_xml(registry)) { + fprintf(stderr, "Validation failed.....\n"); + return 1; + } + + write_model_variables(registry); + + if (parse_reg_xml(registry)) { + fprintf(stderr, "Parsing failed.....\n"); + return 1; + } + + write_default_namelist(registry); + + write_default_streams(registry); + + return 0; +}/*}}}*/ + + +int validate_reg_xml(ezxml_t registry)/*{{{*/ { ezxml_t dims_xml, dim_xml; - ezxml_t structs_xml, var_arr_xml, var_xml; + ezxml_t structs_xml, var_arr_xml, var_xml, stream_var_xml; ezxml_t nmlrecs_xml, nmlopt_xml; + ezxml_t streams_xml, stream_xml, substream_xml; + ezxml_t streams_xml2, stream_xml2; const char *dimname, *dimunits, *dimdesc, *dimdef; - const char *nmlrecname, *nmloptname, *nmlopttype, *nmloptval, *nmloptunits, *nmloptdesc, *nmloptposvals; - const char *structname, *structlevs, *structpackages; - const char *vararrname, *vararrtype, *vararrdims, *vararrpersistence, *vararrpackages; + const char *nmlrecname, *nmlrecindef; + const char *nmloptname, *nmlopttype, *nmloptval, *nmloptunits, *nmloptdesc, *nmloptposvals, *nmloptindef; + const char *structname, *structpackages, *structstreams; + const char *vararrname, *vararrtype, *vararrdims, *vararrpersistence, *vararrpackages, *vararrstreams; const char *varname, *varpersistence, *vartype, *vardims, *varunits, *vardesc, *vararrgroup, *varstreams, *varpackages; - const char *varname_in_code; + const char *varname_in_code, *varname_in_stream; const char *const_model, *const_core, *const_version; + const char *streamname, *streamtype, *streamfilename, *streaminterval_in, *streaminterval_out, *streampackages; + const char *streamimmutable, *streamformat; + const char *streamname2, *streamfilename2; + const char *substreamname, *streamimmutable2; + const char *time_levs; char *string, *err_string; char name_holder[1024]; @@ -140,7 +141,7 @@ int validate_reg_xml(ezxml_t registry) fprintf(stderr,"ERROR: Namelist option %s missing type attribute.\n", nmloptname); return 1; } else if (strcasecmp("logical", nmlopttype) != 0 && strcasecmp("real", nmlopttype) != 0 && - strcasecmp("integer", nmlopttype) != 0 && strcasecmp("character", nmlopttype) != 0) { + strcasecmp("integer", nmlopttype) != 0 && strcasecmp("character", nmlopttype) != 0) { fprintf(stderr,"ERROR: Type of namelist option %s doesn't equal one of logical, real, character, or integer.\n", nmloptname); return 1; } @@ -171,9 +172,24 @@ int validate_reg_xml(ezxml_t registry) snprintf(name_holder, 1024, "%s",dimdef); snprintf(name_holder, 1024, "%s",(name_holder)+9); for (nmlrecs_xml = ezxml_child(registry, "nml_record"); nmlrecs_xml; nmlrecs_xml = nmlrecs_xml->next){ + nmlrecindef = ezxml_attr(nmlrecs_xml, "in_defaults"); + + if(nmlrecindef != NULL){ + if(strncmp(nmlrecindef, "true", 1024) != 0 && strncmp(nmlrecindef, "false", 1024) != 0){ + fprintf(stderr, "ERROR: Namelist record %s has an invalid value for in_defaults attribute. Valide values are true or false.\n", nmlrecname); + } + } for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ nmloptname = ezxml_attr(nmlopt_xml, "name"); nmlopttype = ezxml_attr(nmlopt_xml, "type"); + nmloptindef = ezxml_attr(nmlopt_xml, "in_defaults"); + + + if(nmloptindef != NULL){ + if(strncmp(nmloptindef, "true", 1024) != 0 && strncmp(nmloptindef, "false", 1024) != 0){ + fprintf(stderr, "ERROR: Namelist option %s in record %s has an invalid value for in_defaults attribute. Valide values are true or false.\n", nmloptname, nmlrecname); + } + } if (strncmp(name_holder, nmloptname, 1024) == 0){ if (strcasecmp("integer", nmlopttype) != 0){ @@ -198,17 +214,25 @@ int validate_reg_xml(ezxml_t registry) // Validate Variable Structures for(structs_xml = ezxml_child(registry, "var_struct"); structs_xml; structs_xml = structs_xml->next){ structname = ezxml_attr(structs_xml, "name"); - structlevs = ezxml_attr(structs_xml, "time_levs"); + time_levs = ezxml_attr(structs_xml, "time_levs"); structpackages = ezxml_attr(structs_xml, "packages"); + structstreams = ezxml_attr(structs_xml, "streams"); if (structname == NULL){ fprintf(stderr,"ERROR: Name missing for var_struct.\n"); return 1; } - if (structlevs == NULL){ + if (time_levs == NULL){ fprintf(stderr,"ERROR: time_levs attribute missing for var_struct %s.\n", structname); return 1; + } else { + if (atoi(time_levs) == 0){ + fprintf(stderr, "WARNING: time_levs attribute on var_struct %s is 0. It will be replaced with 1.\n", structname); + } else if (atoi(time_levs) < 1){ + fprintf(stderr, "ERROR: time_levs attribute on var_struct %s is negative.\n", structname); + return 1; + } } if (structpackages != NULL) { @@ -222,6 +246,17 @@ int validate_reg_xml(ezxml_t registry) } } + if (structstreams != NULL) { + string = strdup(structstreams); + err_string = check_streams(registry, string); + free(string); + + if (err_string != NULL) { + fprintf(stderr, "ERROR: Stream %s attached to var_struct %s is not defined.\n", err_string, structname); + return 1; + } + } + // Validate variable arrays for(var_arr_xml = ezxml_child(structs_xml, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){ vararrname = ezxml_attr(var_arr_xml, "name"); @@ -229,17 +264,28 @@ int validate_reg_xml(ezxml_t registry) vararrdims = ezxml_attr(var_arr_xml, "dimensions"); vararrpersistence = ezxml_attr(var_arr_xml, "persistence"); vararrpackages = ezxml_attr(var_arr_xml, "packages"); + vararrstreams = ezxml_attr(var_arr_xml, "streams"); + time_levs = ezxml_attr(var_arr_xml, "time_levs"); if (vararrname == NULL){ fprintf(stderr,"ERROR: Name attribute missing for var_array in var_struct %s.\n", structname); return 1; } + if (time_levs != NULL){ + if (atoi(time_levs) == 0){ + fprintf(stderr, "WARNING: time_levs attribute on var_array %s in var_struct %s is 0. It will be replaced with 1.\n", vararrname, structname); + } else if (atoi(time_levs) < 1){ + fprintf(stderr, "ERROR: time_levs attribute on var_array %s in var_struct %s is negative.\n", vararrname, structname); + return 1; + } + } + if (vararrtype == NULL){ fprintf(stderr,"ERROR: Type attribute missing for var_array %s in var_struct %s.\n", vararrname, structname); return 1; } else if (strcasecmp("logical", vararrtype) != 0 && strcasecmp("real", vararrtype) != 0 && - strcasecmp("integer", vararrtype) != 0 && strcasecmp("text", vararrtype) != 0) { + strcasecmp("integer", vararrtype) != 0 && strcasecmp("text", vararrtype) != 0) { fprintf(stderr,"ERROR: Type attribute on var_array %s in var_struct %s is not equal to one of logical, real, integer, or text.\n", vararrname, structname); return 1; } @@ -285,16 +331,35 @@ int validate_reg_xml(ezxml_t registry) } } + if (persistence == SCRATCH && vararrstreams != NULL){ + fprintf(stderr, "ERROR: Streams attribute not allowed on scratch var_array %s in var_struct %s.\n", vararrname, structname); + return -1; + } + else if (persistence == SCRATCH && vararrstreams == NULL && structstreams != NULL) { + fprintf(stderr, "ERROR: Streams attribute inherited from var_struct %s not allowed on scratch var_array %s in var_struct %s.\n", structname, vararrname, structname); + return -1; + } + else if (persistence == PERSISTENT && vararrstreams != NULL) { + string = strdup(vararrstreams); + err_string = check_streams(registry, string); + free(string); + + if (err_string != NULL) { + fprintf(stderr, "ERROR: Stream %s attached to var_array %s in var_struct %s is not defined.\n", err_string, vararrname, structname); + return 1; + } + } + // Validate variables in variable arrays for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ varname = ezxml_attr(var_xml, "name"); varunits = ezxml_attr(var_xml, "units"); vardesc = ezxml_attr(var_xml, "description"); - varstreams = ezxml_attr(var_xml, "streams"); vararrgroup = ezxml_attr(var_xml, "array_group"); varname_in_code = ezxml_attr(var_xml, "name_in_code"); varpackages = ezxml_attr(var_xml, "packages"); + varstreams = ezxml_attr(var_xml, "streams"); if (varname == NULL) { fprintf(stderr,"ERROR: Name missing for constituent variable in var_array %s in var_struct %s.\n", vararrname, structname); @@ -306,21 +371,16 @@ int validate_reg_xml(ezxml_t registry) return 1; } - if (varstreams != NULL) { - string = strdup(varstreams); - err_string = check_streams(string); - - if (err_string != NULL){ - fprintf(stderr,"ERROR: Stream %s defined on variable %s in var_array %s in var_struct %s is not a valid stream.\n", err_string, varname, vararrname, structname); - return 1; - } - } - if (persistence == SCRATCH && vararrpackages != NULL) { fprintf(stderr, "ERROR: Packages attribute not allowed on constituent variable %s within scratch var_srray %s in var_struct %s.\n", varname, vararrname, structname); return 1; } + if (persistence == SCRATCH && vararrstreams != NULL) { + fprintf(stderr, "ERROR: Streams attribute not allowed on constituent variable %s within scratch var_srray %s in var_struct %s.\n", varname, vararrname, structname); + return 1; + } + if(varpackages != NULL){ string = strdup(varpackages); err_string = check_packages(registry, string); @@ -332,6 +392,17 @@ int validate_reg_xml(ezxml_t registry) } } + if(varstreams != NULL){ + string = strdup(varstreams); + err_string = check_streams(registry, string); + free(string); + + if (err_string != NULL){ + fprintf(stderr, "ERROR: Stream %s attached to constituent variable %s in var_array %s var_struct %s is not defined.\n", err_string, varname, vararrname, structname); + return 1; + } + } + } } @@ -342,20 +413,30 @@ int validate_reg_xml(ezxml_t registry) vardims = ezxml_attr(var_xml, "dimensions"); varunits = ezxml_attr(var_xml, "units"); vardesc = ezxml_attr(var_xml, "description"); - varstreams = ezxml_attr(var_xml, "streams"); varname_in_code = ezxml_attr(var_xml, "name_in_code"); varpackages = ezxml_attr(var_xml, "packages"); + varstreams = ezxml_attr(var_xml, "streams"); + time_levs = ezxml_attr(var_xml, "time_levs"); if (varname == NULL) { fprintf(stderr,"ERROR: Variable name missing in var_struct %s\n.", structname); return 1; } + if (time_levs != NULL){ + if (atoi(time_levs) == 0){ + fprintf(stderr, "WARNING: time_levs attribute on var %s in var_struct %s is 0. It will be replaced with 1.\n", varname, structname); + } else if (atoi(time_levs) < 1){ + fprintf(stderr, "ERROR: time_levs attribute on var %s in var_struct %s is negative.\n", varname, structname); + return 1; + } + } + if(vartype == NULL) { fprintf(stderr,"ERROR: Type attribute missing on variable %s in var_struct %s\n.", varname, structname); return 1; } else if (strcasecmp("logical", vartype) != 0 && strcasecmp("real", vartype) != 0 && - strcasecmp("integer", vartype) != 0 && strcasecmp("text", vartype) != 0) { + strcasecmp("integer", vartype) != 0 && strcasecmp("text", vartype) != 0) { fprintf(stderr,"ERROR: Type attribute on variable %s in var_struct %s is not equal to one of logical, real, integer, or text.\n", varname, structname); return 1; } @@ -364,16 +445,16 @@ int validate_reg_xml(ezxml_t registry) fprintf(stderr,"ERROR: Dimensions attribute missing for variable %s in var_struct %s.\n", varname, structname); return 1; } else { - if (strcasecmp("", vardims) != 0) { - string = strdup(vardims); - err_string = check_dimensions(registry, string); - free(string); - - if(err_string != NULL) { - fprintf(stderr,"ERROR: Dimension %s on variable %s in var_struct %s not defined.\n", err_string, varname, structname); - return 1; - } - } + if (strcasecmp("", vardims) != 0) { + string = strdup(vardims); + err_string = check_dimensions(registry, string); + free(string); + + if(err_string != NULL) { + fprintf(stderr,"ERROR: Dimension %s on variable %s in var_struct %s not defined.\n", err_string, varname, structname); + return 1; + } + } } persistence = PERSISTENT; @@ -402,808 +483,307 @@ int validate_reg_xml(ezxml_t registry) fprintf(stderr, "ERROR: Packages attribute inherited from var_struct %s not allowed on scratch var %s in var_struct %s.\n", structname, varname, structname); return -1; } - - if (varstreams != NULL) { + if (varstreams != NULL && persistence == PERSISTENT) { string = strdup(varstreams); - err_string = check_streams(string); + err_string = check_streams(registry, string); + free(string); - if (err_string != NULL){ - fprintf(stderr,"ERROR: Stream %s defined on variable %s in var_struct %s is not a valid stream.\n", err_string, varname, structname); + if (err_string != NULL) { + fprintf(stderr, "ERROR: Stream %s attached to variable %s in var_struct %s is not defined.\n", err_string, varname, structname); return 1; } + } + else if ( persistence == SCRATCH && varstreams != NULL ) { + fprintf(stderr, "ERROR: Streams attribute not allowed on scratch variable %s in var_struct %s.\n", varname, structname); + return -1; + } + else if ( persistence == SCRATCH && varstreams == NULL && structstreams != NULL) { + fprintf(stderr, "ERROR: Streams attribute inherited from var_struct %s not allowed on scratch var %s in var_struct %s.\n", structname, varname, structname); + return -1; } + } } - return 0; -} - -int parse_reg_xml(ezxml_t registry, struct namelist **nls, struct dimension ** dims, struct variable ** vars, struct group_list ** groups, struct package ** pkgs, char * modelname, char * corename, char * version) -{ - struct namelist * nls_ptr, *nls_ptr2; - struct namelist * nls_chk_ptr; - struct dimension * dim_ptr, *dim_ptr2; - struct variable * var_ptr, *var_ptr2; - struct dimension_list * dimlist_ptr; - struct dimension * dimlist_cursor; - struct group_list * grouplist_ptr; - struct variable_list * vlist_cursor; - struct package * pkg_ptr; - - ezxml_t dims_xml, dim_xml; - ezxml_t structs_xml, var_arr_xml, var_xml; - ezxml_t nmlrecs_xml, nmlopt_xml; - ezxml_t packages_xml, package_xml; - - const char *dimname, *dimunits, *dimdesc, *dimdef; - const char *nmlrecname, *nmloptname, *nmlopttype, *nmloptval, *nmloptunits, *nmloptdesc, *nmloptposvals; - const char *structname, *structlevs, *structpackages; - const char *vararrname, *vararrtype, *vararrdims, *vararrpersistence, *vararrdefaultval, *vararrpackages; - const char *varname, *varpersistence, *vartype, *vardims, *varunits, *vardesc, *vararrgroup, *varstreams, *vardefaultval, *varpackages; - const char *packagename, *packagedesc; - const char *varname_in_code; - const char *const_model, *const_core, *const_version; - - char dimensions[2048]; - char *dimension_list; - char dimension_buffer[128]; - char streams_buffer[128]; - char default_value[1024]; - - char *string, *tofree, *token; - - NEW_NAMELIST(nls_ptr) - NEW_DIMENSION(dim_ptr) - NEW_VARIABLE(var_ptr) - NEW_GROUP_LIST(grouplist_ptr); - NEW_PACKAGE(pkg_ptr); - *nls = nls_ptr; - *dims = dim_ptr; - *vars = var_ptr; - *groups = grouplist_ptr; - *pkgs = pkg_ptr; - - snprintf(pkg_ptr->name, 1024, "%c", '\0'); - - // Get model information - const_model = ezxml_attr(registry, "model"); - const_core = ezxml_attr(registry, "core"); - const_version = ezxml_attr(registry, "version"); - - if(const_model == NULL) - sprintf(modelname, "MISSING"); - else - sprintf(modelname, "%s", const_model); - - if(const_core == NULL) - sprintf(corename, "MISSING"); - else - sprintf(corename, "%s", const_core); - - if(const_version == NULL) - sprintf(version, "MISSING"); - else - sprintf(version, "%s", const_version); - - // Parse Namelist Records - for (nmlrecs_xml = ezxml_child(registry, "nml_record"); nmlrecs_xml; nmlrecs_xml = nmlrecs_xml->next){ - nmlrecname = ezxml_attr(nmlrecs_xml, "name"); - for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ - nmloptname = ezxml_attr(nmlopt_xml, "name"); - nmlopttype = ezxml_attr(nmlopt_xml, "type"); - nmloptval = ezxml_attr(nmlopt_xml, "default_value"); - nmloptunits = ezxml_attr(nmlopt_xml, "units"); - nmloptdesc = ezxml_attr(nmlopt_xml, "description"); - nmloptposvals = ezxml_attr(nmlopt_xml, "possible_values"); - - snprintf(nls_ptr->record, 1024, "%s", nmlrecname); - snprintf(nls_ptr->name, 1024, "%s", nmloptname); - - if(strncmp(nmlopttype, "real", 1024) == 0){ - nls_ptr->vtype = REAL; - } else if(strncmp(nmlopttype, "integer", 1024) == 0){ - nls_ptr->vtype = INTEGER; - } else if(strncmp(nmlopttype, "logical", 1024) == 0){ - nls_ptr->vtype = LOGICAL; - } else if(strncmp(nmlopttype, "character", 1024) == 0){ - nls_ptr->vtype = CHARACTER; + // Validate default streams + for (streams_xml = ezxml_child(registry, "streams"); streams_xml; streams_xml = streams_xml->next) { + for (stream_xml = ezxml_child(streams_xml, "stream"); stream_xml; stream_xml = stream_xml->next) { + streamname = ezxml_attr(stream_xml, "name"); + streamtype = ezxml_attr(stream_xml, "type"); + streamfilename = ezxml_attr(stream_xml, "filename_template"); + streaminterval_in = ezxml_attr(stream_xml, "input_interval"); + streaminterval_out = ezxml_attr(stream_xml, "output_interval"); + streampackages = ezxml_attr(stream_xml, "packages"); + streamimmutable = ezxml_attr(stream_xml, "immutable"); + streamformat = ezxml_attr(stream_xml, "runtime_format"); + + if (streamname == NULL) { + fprintf(stderr, "ERROR: Stream specification missing \"name\" attribute.\n"); + return 1; } - - switch(nls_ptr->vtype){ - case REAL: - nls_ptr->defval.rval = (float)atof(nmloptval); - break; - case INTEGER: - nls_ptr->defval.ival = atoi(nmloptval); - break; - case LOGICAL: - if(strncmp(nmloptval, "true", 1024) ==0){ - nls_ptr->defval.lval = 1; - } else if (strncmp(nmloptval, "false", 1024) == 0){ - nls_ptr->defval.lval = 0; - } - break; - case CHARACTER: - snprintf(nls_ptr->defval.cval, 32, "%s", nmloptval); - break; + else if (streamtype == NULL) { + fprintf(stderr, "ERROR: Stream specification for %s missing \"type\" attribute.\n", streamname); + return 1; } - - NEW_NAMELIST(nls_ptr->next) - nls_ptr2 = nls_ptr; - nls_ptr = nls_ptr->next; - } - } - - if(nls_ptr2->next) free(nls_ptr2->next); - nls_ptr2->next = NULL; - - // Parse Packages - for (packages_xml = ezxml_child(registry, "packages"); packages_xml; packages_xml = packages_xml->next){ - for (package_xml = ezxml_child(packages_xml, "package"); package_xml; package_xml = package_xml->next){ - packagename = ezxml_attr(package_xml, "name"); - packagedesc = ezxml_attr(package_xml, "description"); - - if (strlen(pkg_ptr->name) == 0) { - snprintf(pkg_ptr->name, 1024, "%s", packagename); - } else { - NEW_PACKAGE(pkg_ptr->next); - pkg_ptr = pkg_ptr->next; - snprintf(pkg_ptr->name, 1024, "%s", packagename); + else if (streamfilename == NULL) { + fprintf(stderr, "ERROR: Stream specification for %s missing \"filename_template\" attribute.\n", streamname); + return 1; } - } - } - - // Parse Dimensions - for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ - for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ - dimname = ezxml_attr(dim_xml, "name"); - dimdef = ezxml_attr(dim_xml, "definition"); - dimunits = ezxml_attr(dim_xml, "units"); - dimdesc = ezxml_attr(dim_xml, "description"); - - dim_ptr->namelist_defined = 0; - - snprintf(dim_ptr->name_in_file, 1024, "%s", dimname); - if(dimdef == NULL){ - snprintf(dim_ptr->name_in_code, 1024, "%s", dimname); - dim_ptr->constant_value = -1; - } else { - snprintf(dim_ptr->name_in_code, 1024, "%s", dimdef); - // Check namelist defined ?? - dim_ptr->constant_value = is_integer_constant(dim_ptr->name_in_code); - if(strncmp(dim_ptr->name_in_code, "namelist:", 9) == 0) { - dim_ptr->namelist_defined = 1; - snprintf(dim_ptr->name_in_code, 1024, "%s", (dim_ptr->name_in_code)+9); - - /* Check that the referenced namelist variable is defined as an integer variable */ - nls_chk_ptr = (*nls)->next; - while (nls_chk_ptr) { - if (strncmp(nls_chk_ptr->name, dim_ptr->name_in_code, 1024) == 0) { - if (nls_chk_ptr->vtype != INTEGER) { - fprintf(stderr,"\nRegistry error: Namelist variable %s must be an integer for namelist-derived dimension %s\n\n", nls_chk_ptr->name, dim_ptr->name_in_file); - return 1; + else if (strstr(streamtype, "input") != NULL && streaminterval_in == NULL) { + fprintf(stderr, "ERROR: Stream %s is marked as input but is missing \"input_interval\" attribute.\n", streamname); + return 1; + } + else if (strstr(streamtype, "output") != NULL && streaminterval_out == NULL) { + fprintf(stderr, "ERROR: Stream %s is marked as output but is missing \"output_interval\" attribute.\n", streamname); + return 1; + } + else if (streamformat == NULL && (streamimmutable == NULL || (streamimmutable != NULL && strcmp(streamimmutable,"true") != 0))) { + fprintf(stderr, "ERROR: Mutable stream %s must have the \"runtime_format\" attribute.\n", streamname); + return 1; + } + else { + /* Check that each stream added to an immutable stream is immutable */ + if (streamimmutable != NULL && strcmp(streamimmutable, "true") == 0) { + for (substream_xml = ezxml_child(stream_xml, "stream"); substream_xml; substream_xml = substream_xml->next){ + substreamname = ezxml_attr(substream_xml, "name"); + found = 0; + + for (streams_xml2 = ezxml_child(registry, "streams"); streams_xml2; streams_xml2 = streams_xml2->next){ + for (stream_xml2 = ezxml_child(streams_xml2, "stream"); stream_xml2; stream_xml2 = stream_xml2->next){ + streamname2 = ezxml_attr(stream_xml2, "name"); + + if (substreamname != NULL && streamname2 != NULL && strcmp(substreamname, streamname2) == 0){ + streamimmutable2 = ezxml_attr(stream_xml2, "immutable"); + found = 1; + + if (streamimmutable2 == NULL || strcmp(streamimmutable2, "true") != 0){ + fprintf(stderr, "ERROR: Immutable stream %s cannot contain mutable streams (e.g. %s).\n", streamname, substreamname); + return 1; + } + } } - break; - } - nls_chk_ptr = nls_chk_ptr->next; + } } - if (!nls_chk_ptr) { - fprintf(stderr,"\nRegistry error: Namelist variable %s not defined for namelist-derived dimension %s\n\n", dim_ptr->name_in_code, dim_ptr->name_in_file); + } + for (stream_var_xml = ezxml_child(stream_xml, "var"); stream_var_xml; stream_var_xml = stream_var_xml->next) { + varname_in_stream = ezxml_attr(stream_var_xml, "name"); + if (varname_in_stream == NULL) { + fprintf(stderr, "ERROR: Variable field in stream \"%s\" specification missing \"name\" attribute.\n", streamname); return 1; } - } - } - - NEW_DIMENSION(dim_ptr->next) - dim_ptr2 = dim_ptr; - dim_ptr = dim_ptr->next; - } - } - - if(dim_ptr2->next) free(dim_ptr2->next); - dim_ptr2->next = NULL; - - // Parse Variable Structures - for(structs_xml = ezxml_child(registry, "var_struct"); structs_xml; structs_xml = structs_xml->next){ - structname = ezxml_attr(structs_xml, "name"); - structlevs = ezxml_attr(structs_xml, "time_levs"); - structpackages = ezxml_attr(structs_xml, "packages"); - - grouplist_ptr = *groups; - while(grouplist_ptr->next) grouplist_ptr = grouplist_ptr->next; - NEW_GROUP_LIST(grouplist_ptr->next); - grouplist_ptr = grouplist_ptr->next; - snprintf(grouplist_ptr->name, 1024, "%s", structname); - grouplist_ptr->ntime_levs = atoi(structlevs); - vlist_cursor = NULL; - - // Parse variable arrays - for(var_arr_xml = ezxml_child(structs_xml, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){ - vararrname = ezxml_attr(var_arr_xml, "name"); - vararrtype = ezxml_attr(var_arr_xml, "type"); - vararrdims = ezxml_attr(var_arr_xml, "dimensions"); - vararrpersistence = ezxml_attr(var_arr_xml, "persistence"); - vararrdefaultval = ezxml_attr(var_arr_xml, "default_value"); - vararrpackages = ezxml_attr(var_arr_xml, "packages"); - - //Parse variables in variable arrays - for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ - varname = ezxml_attr(var_xml, "name"); - varunits = ezxml_attr(var_xml, "units"); - vardesc = ezxml_attr(var_xml, "description"); - varstreams = ezxml_attr(var_xml, "streams"); - vararrgroup = ezxml_attr(var_xml, "array_group"); - varname_in_code = ezxml_attr(var_xml, "name_in_code"); - varpackages = ezxml_attr(var_xml, "packages"); - - if(vlist_cursor == NULL){ - NEW_VARIABLE_LIST(grouplist_ptr->vlist); - vlist_cursor = grouplist_ptr->vlist; - } else { - NEW_VARIABLE_LIST(vlist_cursor->next); - vlist_cursor->next->prev = vlist_cursor; - vlist_cursor = vlist_cursor->next; - } - vlist_cursor->var = var_ptr; - vlist_cursor->next = NULL; + /* Check that runtime_format is a valid option for mutable streams */ + if (streamimmutable == NULL || (streamimmutable != NULL && strcmp(streamimmutable,"true") != 0)) { + if (strcmp(streamformat, "single_file") != 0 && strcmp(streamformat, "separate_file") != 0) { + fprintf(stderr, "ERROR: Runtime_format specification for stream \"%s\" must be either \"single_file\" or \"separate_file\".\n", streamname); + return 1; + } + } - var_ptr->ndims = 0; - var_ptr->timedim = 0; - var_ptr->iostreams = 0; - snprintf(var_ptr->name_in_file, 1024, "%s", varname); + /* Check that the variable being added to the stream has been defined */ + for (structs_xml = ezxml_child(registry, "var_struct"); structs_xml; structs_xml = structs_xml->next) { + for (var_arr_xml = ezxml_child(structs_xml, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next) { + for (var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next) { + varname = ezxml_attr(var_xml, "name"); + if (strcmp(varname, varname_in_stream) == 0) { + goto done_searching; + } + } + } + for (var_xml = ezxml_child(structs_xml, "var"); var_xml; var_xml = var_xml->next) { + varname = ezxml_attr(var_xml, "name"); + if (strcmp(varname, varname_in_stream) == 0) { + goto done_searching; + } + } + } - var_ptr->persistence = PERSISTENT; - if(vararrpersistence != NULL){ - var_ptr->persistence = check_persistence(vararrpersistence); - if (var_ptr->persistence == -1) return 1; - } +done_searching: - /* Check var_arr packages attribute */ - if(varpackages == NULL) { - varpackages = ezxml_attr(var_arr_xml, "packages"); - } + /* did we find what we were looking for? */ + if (var_xml == NULL) { + fprintf(stderr, "ERROR: Trying to add undefined variable %s to stream %s.\n", varname_in_stream, streamname); + return 1; + } - /* Check var_struct packages attribute */ - if(varpackages == NULL) { - varpackages = ezxml_attr(structs_xml, "packages"); - } - if(varpackages != NULL && var_ptr->persistence == PERSISTENT){ - var_ptr->persistence = PACKAGE; } + } - if(var_ptr->persistence == PACKAGE) { - NEW_PACKAGE(var_ptr->package_name); - - string = strdup(varpackages); - tofree = string; - token = strsep(&string, ";"); - - snprintf(var_ptr->package_name->name, 1024, "%s", token); - pkg_ptr = var_ptr->package_name; + if (streamformat != NULL && streamimmutable != NULL && strcmp(streamimmutable,"true") == 0) { + fprintf(stderr, "Warning: runtime_format attribute has no effect for immutable stream \"%s\".\n", streamname); + } - while( (token = strsep(&string, ";")) != NULL) { - NEW_PACKAGE(pkg_ptr->next); - pkg_ptr = pkg_ptr->next; - snprintf(pkg_ptr->name, 1024, "%s", token); - } - } + if (streampackages != NULL) { + string = strdup(streampackages); + err_string = check_packages(registry, string); + free(string); - if(strncmp(vararrtype, "real", 1024) == 0){ - var_ptr->vtype = REAL; - snprintf(default_value, 1024, "0.0_RKIND"); - } else if(strncmp(vararrtype, "integer", 1024) == 0){ - var_ptr->vtype = INTEGER; - snprintf(default_value, 1024, "0"); - } else if(strncmp(vararrtype, "logical", 1024) == 0){ - var_ptr->vtype = LOGICAL; - snprintf(default_value, 1024, ".false."); - } else if(strncmp(vararrtype, "text", 1024) == 0){ - var_ptr->vtype = CHARACTER; - snprintf(default_value, 1024, "''"); + if (err_string != NULL){ + fprintf(stderr, "ERROR: Package %s used on stream %s is not defined.\n", err_string, streamname); + return 1; } + } - NEW_DIMENSION_LIST(dimlist_ptr) - var_ptr->dimlist = dimlist_ptr; - - snprintf(dimensions,2048, "%s", vararrdims); - dimension_list = strtok(dimensions, " "); - while(dimension_list != NULL){ - snprintf(dimension_buffer, 128, "%s", dimension_list); - if(strncmp(dimension_buffer, "Time", 1024) == 0){ - var_ptr->timedim = 1; - } else { - NEW_DIMENSION_LIST(dimlist_ptr->next) - dimlist_ptr->next->prev = dimlist_ptr; - dimlist_ptr = dimlist_ptr->next; - - dimlist_cursor = (*dims); - while(dimlist_cursor && (strncmp(dimension_buffer, dimlist_cursor->name_in_file, 1024) != 0)){ - dimlist_cursor = dimlist_cursor->next; - } - if (dimlist_cursor) { - dimlist_ptr->dim = dimlist_cursor; - } else { - fprintf(stderr, "Error: Unknown dimension %s for variable %s\n", dimension_buffer, var_ptr->name_in_file); + } + } + for (streams_xml = ezxml_child(registry, "streams"); streams_xml; streams_xml = streams_xml->next) { + for (stream_xml = ezxml_child(streams_xml, "stream"); stream_xml; stream_xml = stream_xml->next) { + streamname = ezxml_attr(stream_xml, "name"); + streamfilename = ezxml_attr(stream_xml, "filename_template"); + + /* Check that this stream's filename template is unique among all streams */ + for (streams_xml2 = ezxml_child(registry, "streams"); streams_xml2; streams_xml2 = streams_xml2->next) { + for (stream_xml2 = ezxml_child(streams_xml2, "stream"); stream_xml2; stream_xml2 = stream_xml2->next) { + streamname2 = ezxml_attr(stream_xml2, "name"); + streamfilename2 = ezxml_attr(stream_xml2, "filename_template"); + + if (stream_xml != stream_xml2) { + if (strcmp(streamfilename, streamfilename2) == 0) { + fprintf(stderr, "ERROR: Streams %s and %s have a conflicting filename template of %s.\n", streamname, streamname2, streamfilename); return 1; } - var_ptr->ndims++; } - dimension_list = strtok(NULL, " "); - } - dimlist_ptr = var_ptr->dimlist; - if(var_ptr->dimlist) var_ptr->dimlist = var_ptr->dimlist->next; - free(dimlist_ptr); - - if(varstreams != NULL){ - snprintf(streams_buffer, 128, "%s", varstreams); - if(strchr(streams_buffer, (int)'i')) var_ptr->iostreams |= INPUT0; - if(strchr(streams_buffer, (int)'s')) var_ptr->iostreams |= SFC0; - if(strchr(streams_buffer, (int)'r')) var_ptr->iostreams |= RESTART0; - if(strchr(streams_buffer, (int)'o')) var_ptr->iostreams |= OUTPUT0; - } - - if(varname_in_code == NULL){ - snprintf(var_ptr->name_in_code, 1024, "%s", varname); - } else { - snprintf(var_ptr->name_in_code, 1024, "%s", varname_in_code); } - - if(vararrdefaultval == NULL){ - snprintf(var_ptr->default_value, 1024, "%s", default_value); - } else { - snprintf(var_ptr->default_value, 1024, "%s", vararrdefaultval); - } - - snprintf(var_ptr->var_array, 1024, "%s", vararrname); - snprintf(var_ptr->array_class, 1024, "%s", vararrgroup); - - NEW_VARIABLE(var_ptr->next); - var_ptr2 = var_ptr; - var_ptr = var_ptr->next; } } + } - for(var_xml = ezxml_child(structs_xml, "var"); var_xml; var_xml = var_xml->next){ - varname = ezxml_attr(var_xml, "name"); - varpersistence = ezxml_attr(var_xml, "persistence"); - vartype = ezxml_attr(var_xml, "type"); - vardims = ezxml_attr(var_xml, "dimensions"); - varunits = ezxml_attr(var_xml, "units"); - vardesc = ezxml_attr(var_xml, "description"); - varstreams = ezxml_attr(var_xml, "streams"); - varname_in_code = ezxml_attr(var_xml, "name_in_code"); - vardefaultval = ezxml_attr(var_xml, "default_value"); - varpackages = ezxml_attr(var_xml, "packages"); - - if(vlist_cursor == NULL){ - NEW_VARIABLE_LIST(grouplist_ptr->vlist); - vlist_cursor = grouplist_ptr->vlist; - } else { - NEW_VARIABLE_LIST(vlist_cursor->next); - vlist_cursor->next->prev = vlist_cursor; - vlist_cursor = vlist_cursor->next; - } - vlist_cursor->var = var_ptr; - vlist_cursor->next = NULL; + if(check_for_unique_names(registry, registry)){ + fprintf(stderr, "ERROR: Structures and Fields are required to have unique names for I/O reasons.\n"); + fprintf(stderr, " Please fix duplicates in the Registry.xml file.\n"); + fprintf(stderr, " You may use the name_in_code attribute to give them the same name inside the model,\n"); + fprintf(stderr, " but the name attribute is required to be unique.\n"); + return 1; + } - var_ptr->ndims = 0; - var_ptr->timedim = 0; - var_ptr->iostreams = 0; + return 0; +}/*}}}*/ - snprintf(var_ptr->name_in_file, 1024, "%s", varname); - var_ptr->persistence = PERSISTENT; - if(varpersistence != NULL){ - var_ptr->persistence = check_persistence(varpersistence); - if(var_ptr->persistence == -1) return 1; - } +int parse_reg_xml(ezxml_t registry)/*{{{*/ +{ + ezxml_t dims_xml, dim_xml; + ezxml_t structs_xml, var_arr_xml, var_xml; + ezxml_t nmlrecs_xml, nmlopt_xml; + ezxml_t packages_xml, package_xml; + ezxml_t streams_xml, stream_xml; - /* Check packages attribute on var_struct */ - if(varpackages == NULL){ - varpackages = ezxml_attr(structs_xml, "packages"); - } + int err; - if(varpackages != NULL && var_ptr->persistence == PERSISTENT){ - var_ptr->persistence = PACKAGE; - } - if(var_ptr->persistence == PACKAGE) { - NEW_PACKAGE(var_ptr->package_name); + // Parse Packages + err = parse_packages_from_registry(registry); - string = strdup(varpackages); - tofree = string; - token = strsep(&string, ";"); + // Parse namelist records + err = parse_namelist_records_from_registry(registry); - snprintf(var_ptr->package_name->name, 1024, "%s", token); - pkg_ptr = var_ptr->package_name; + // Parse dimensions + err = parse_dimensions_from_registry(registry); - while( (token = strsep(&string, ";")) != NULL) { - NEW_PACKAGE(pkg_ptr->next); - pkg_ptr = pkg_ptr->next; - snprintf(pkg_ptr->name, 1024, "%s", token); - } - } + // Parse variable structures + err = parse_structs_from_registry(registry); + // Generate routines to link fields for multiple blocks + err = generate_field_links(registry); - if(strncmp(vartype, "real", 1024) == 0){ - var_ptr->vtype = REAL; - snprintf(default_value, 1024, "0.0_RKIND"); - } else if(strncmp(vartype, "integer", 1024) == 0){ - var_ptr->vtype = INTEGER; - snprintf(default_value, 1024, "0"); - } else if(strncmp(vartype, "logical", 1024) == 0){ - var_ptr->vtype = LOGICAL; - snprintf(default_value, 1024, ".false."); - } else if(strncmp(vartype, "text", 1024) == 0){ - var_ptr->vtype = CHARACTER; - snprintf(default_value, 1024, "''"); - } + // Generate code to read and write fields + err = generate_immutable_streams(registry); - NEW_DIMENSION_LIST(dimlist_ptr) - var_ptr->dimlist = dimlist_ptr; - - snprintf(dimensions, 2048, "%s", vardims); - dimension_list = strtok(dimensions, " "); - while(dimension_list != NULL){ - snprintf(dimension_buffer, 128, "%s", dimension_list); - if(strncmp(dimension_buffer, "Time", 1024) == 0){ - var_ptr->timedim = 1; - } else { - NEW_DIMENSION_LIST(dimlist_ptr->next) - dimlist_ptr->next->prev = dimlist_ptr; - dimlist_ptr = dimlist_ptr->next; - - dimlist_cursor = (*dims); - while(dimlist_cursor && (strncmp(dimension_buffer, dimlist_cursor->name_in_file, 1024) != 0) ) - dimlist_cursor = dimlist_cursor->next; - if (dimlist_cursor) { - dimlist_ptr->dim = dimlist_cursor; - } else { - fprintf(stderr, "Error: Unknown dimension %s for variable %s\n", dimension_buffer, var_ptr->name_in_file); - return 1; - } - var_ptr->ndims++; - } - dimension_list = strtok(NULL, " "); - } + return 0; +}/*}}}*/ - dimlist_ptr = var_ptr->dimlist; - if(var_ptr->dimlist) var_ptr->dimlist = var_ptr->dimlist->next; - free(dimlist_ptr); - if(varstreams != NULL){ - snprintf(streams_buffer, 128, "%s", varstreams); - if(strchr(streams_buffer, (int)'i')) { - var_ptr->iostreams |= INPUT0; - } - if(strchr(streams_buffer, (int)'s')) { - var_ptr->iostreams |= SFC0; - } - if(strchr(streams_buffer, (int)'r')) { - var_ptr->iostreams |= RESTART0; - } - if(strchr(streams_buffer, (int)'o')) { - var_ptr->iostreams |= OUTPUT0; - } - } +int is_unique_field(ezxml_t registry, ezxml_t field, const char *check_name){/*{{{*/ + ezxml_t struct_xml, var_arr_xml, var_xml; - if(varname_in_code == NULL){ - snprintf(var_ptr->name_in_code, 1024, "%s", varname); - } else { - snprintf(var_ptr->name_in_code, 1024, "%s", varname_in_code); - } + const char *name; - snprintf(var_ptr->var_array, 1024, "-"); - snprintf(var_ptr->array_class, 1024, "-"); + for(struct_xml = ezxml_child(registry, "var_struct"); struct_xml; struct_xml = struct_xml->next){ + for(var_arr_xml = ezxml_child(struct_xml, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){ + for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ + name = ezxml_attr(var_xml, "name"); - if(vardefaultval == NULL){ - snprintf(var_ptr->default_value, 1024, "%s", default_value); - } else { - snprintf(var_ptr->default_value, 1024, "%s", vardefaultval); + if(strcmp(name, check_name) == 0 && var_xml != field){ + return 0; + } } + } + for(var_xml = ezxml_child(struct_xml, "var"); var_xml; var_xml = var_xml->next){ + name = ezxml_attr(var_xml, "name"); - NEW_VARIABLE(var_ptr->next); - var_ptr2 = var_ptr; - var_ptr = var_ptr->next; + if(strcmp(name, check_name) == 0 && var_xml != field){ + return 0; + } } } - if(var_ptr2->next) free(var_ptr2->next); - var_ptr2->next = NULL; + return 1; +}/*}}}*/ - grouplist_ptr = *groups; - if ((*groups)->next) *groups = (*groups)->next; - if (grouplist_ptr) free(grouplist_ptr); - return 0; -} +int is_unique_struct(ezxml_t current_position, ezxml_t check_struct, const char *check_name){/*{{{*/ + ezxml_t struct_xml; -int getword(FILE * regfile, char * word) -{ - int i; - int c; - - i = 0; - - do { c = getc(regfile); } while (((char)c == ' ' || (char)c == '\n' || (char)c == '\t') && c != EOF); - - while ((char)c == '%') { - do { c = getc(regfile); } while ((char)c != '\n' && c != EOF); - do { c = getc(regfile); } while (((char)c == ' ' || (char)c == '\n' || (char)c == '\t') && c != EOF); - }; - while((char)c != ' ' && (char)c != '\n' && (char)c != '\t' && c != EOF && (char)c != '%') { - word[i++] = (char)c; - c = (char)getc(regfile); - } - word[i] = '\0'; - - if ((char)c == '%') do { c = getc(regfile); } while ((char)c != '\n' && c != EOF); - - fprintf(stdout,"%s ",word); - return c; -} - -int is_integer_constant(char * c) { - int i; - - i = 0; - while (c[i] != '\0') { - if (c[i] < '0' || c[i] > '9') return -1; - i++; - } - - return atoi(c); -} - -void sort_vars(struct variable * vars) -{ - struct variable * var_ptr; - struct variable * var_ptr2; - struct variable * var_ptr2_prev; - char var_array[1024]; - char array_class[1024]; - - var_ptr = vars; - -/* Attempt at sorting first on super-array, then on class in the same loop - while (var_ptr) { - memcpy(var_array, var_ptr->var_array, 1024); - memcpy(array_class, var_ptr->array_class, 1024); - var_ptr2_prev = var_ptr; - var_ptr2 = var_ptr->next; - if (var_ptr2 && - (strncmp(var_array, var_ptr2->var_array, 1024) != 0 || strncmp(array_class, var_ptr2->array_class, 1024) != 0)) { - while (var_ptr2) { - if (strncmp(var_array, var_ptr2->var_array, 1024) == 0 && strncmp(array_class, var_ptr2->array_class, 1024) == 0) { - var_ptr2_prev->next = var_ptr2->next; - var_ptr2->next = var_ptr->next; - var_ptr->next = var_ptr2; - var_ptr2 = var_ptr2_prev->next; - } - else { - var_ptr2_prev = var_ptr2_prev->next; - var_ptr2 = var_ptr2->next; - } - } - } - var_ptr = var_ptr->next; - } -*/ - - while (var_ptr) { - memcpy(var_array, var_ptr->var_array, 1024); - var_ptr2_prev = var_ptr; - var_ptr2 = var_ptr->next; - if (var_ptr2 && strncmp(var_array, var_ptr2->var_array, 1024) != 0) { - while (var_ptr2) { - if (strncmp(var_array, var_ptr2->var_array, 1024) == 0) { - var_ptr2_prev->next = var_ptr2->next; - var_ptr2->next = var_ptr->next; - var_ptr->next = var_ptr2; - var_ptr2 = var_ptr2_prev->next; - } - else { - var_ptr2_prev = var_ptr2_prev->next; - var_ptr2 = var_ptr2->next; - } - } - } - var_ptr = var_ptr->next; - } - - var_ptr = vars; - - while (var_ptr) { - memcpy(array_class, var_ptr->array_class, 1024); - var_ptr2_prev = var_ptr; - var_ptr2 = var_ptr->next; - if (var_ptr2 && strncmp(array_class, var_ptr2->array_class, 1024) != 0) { - while (var_ptr2) { - if (strncmp(array_class, var_ptr2->array_class, 1024) == 0) { - var_ptr2_prev->next = var_ptr2->next; - var_ptr2->next = var_ptr->next; - var_ptr->next = var_ptr2; - var_ptr2 = var_ptr2_prev->next; - } - else { - var_ptr2_prev = var_ptr2_prev->next; - var_ptr2 = var_ptr2->next; - } - } - } - var_ptr = var_ptr->next; - } -} - - -void sort_group_vars(struct group_list * groups) -{ - struct variable_list * var_list; - struct variable_list * var_ptr; - struct variable_list * var_ptr2; - struct variable_list * var_ptr2_prev; - struct group_list * group_ptr; - char var_array[1024]; - char array_class[1024]; - - group_ptr = groups; - - while (group_ptr) { - - var_ptr = group_ptr->vlist; - - while (var_ptr) { - memcpy(var_array, var_ptr->var->var_array, 1024); - var_ptr2_prev = var_ptr; - var_ptr2 = var_ptr->next; - if (var_ptr2 != NULL && strncmp(var_array, var_ptr2->var->var_array, 1024) != 0) { - while (var_ptr2) { - if (strncmp(var_array, var_ptr2->var->var_array, 1024) == 0) { - var_ptr2_prev->next = var_ptr2->next; - var_ptr2->next = var_ptr->next; - var_ptr->next = var_ptr2; - var_ptr2 = var_ptr2_prev->next; - } - else { - var_ptr2_prev = var_ptr2_prev->next; - var_ptr2 = var_ptr2->next; - } - } - } - var_ptr = var_ptr->next; - } - - var_ptr = group_ptr->vlist; - - while (var_ptr) { - memcpy(array_class, var_ptr->var->array_class, 1024); - var_ptr2_prev = var_ptr; - var_ptr2 = var_ptr->next; - if (var_ptr2 && strncmp(array_class, var_ptr2->var->array_class, 1024) != 0) { - while (var_ptr2) { - if (strncmp(array_class, var_ptr2->var->array_class, 1024) == 0) { - var_ptr2_prev->next = var_ptr2->next; - var_ptr2->next = var_ptr->next; - var_ptr->next = var_ptr2; - var_ptr2 = var_ptr2_prev->next; - } - else { - var_ptr2_prev = var_ptr2_prev->next; - var_ptr2 = var_ptr2->next; - } - } - } - var_ptr = var_ptr->next; - } - - group_ptr = group_ptr->next; - } -} - -char * check_packages(ezxml_t registry, char * packages){ - ezxml_t packages_xml, package_xml; + const char *name; - const char *packagename; + int test; - char *string, *tofree, *token; - char *failed; - int missing_package; - string = strdup(packages); - tofree = string; - failed = NULL; + test = 1; - while( (token = strsep(&string, ";")) != NULL) { - missing_package = 1; - for (packages_xml = ezxml_child(registry, "packages"); packages_xml; packages_xml = packages_xml->next){ - for (package_xml = ezxml_child(packages_xml, "package"); package_xml; package_xml = package_xml->next){ - packagename = ezxml_attr(package_xml, "name"); + for(struct_xml = ezxml_child(current_position, "var_struct"); struct_xml; struct_xml = struct_xml->next){ + name = ezxml_attr(struct_xml, "name"); - if(strcasecmp(packagename, token) == 0){ - missing_package = 0; - } + if(strcmp(name, check_name) == 0 && struct_xml != check_struct){ + return 0; + } else { + test = is_unique_struct(struct_xml, check_struct, check_name); + if ( !test ) { + return 0; } } - - if (missing_package) { - failed = strdup(token); - free(tofree); - return failed; - } } - free(tofree); - return failed; -} -char * check_dimensions(ezxml_t registry, char * dims){ - ezxml_t dims_xml, dim_xml; + return 1; +}/*}}}*/ - const char *dimname; - char *string, *tofree, *token; - int missing_dim; +int check_for_unique_names(ezxml_t registry, ezxml_t current_position){/*{{{*/ + ezxml_t struct_xml, var_arr_xml, var_xml; - string = strdup(dims); - tofree = string; + const char *name; - while( (token = strsep(&string, " ")) != NULL) { - if (strcasecmp(token, "Time") != 0){ - missing_dim = 1; - for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ - for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ - dimname = ezxml_attr(dim_xml, "name"); + for(struct_xml = ezxml_child(current_position, "var_struct"); struct_xml; struct_xml = struct_xml->next){ + name = ezxml_attr(struct_xml, "name"); - if(strcasecmp(dimname, token) == 0){ - missing_dim = 0; - } + if(!is_unique_struct(registry, struct_xml, name)){ + fprintf(stderr, "ERROR: Struct %s is not uniqe.\n", name); + return 1; + } + + for(var_arr_xml = ezxml_child(struct_xml, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){ + for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ + name = ezxml_attr(var_xml, "name"); + if(!is_unique_field(registry, var_xml, name)){ + fprintf(stderr, "ERROR: Field %s is not unique.\n", name); + return 1; } } + } - if (missing_dim) { - free(tofree); - return token; + for(var_xml = ezxml_child(struct_xml, "var"); var_xml; var_xml = var_xml->next){ + name = ezxml_attr(var_xml, "name"); + if(!is_unique_field(registry, var_xml, name)){ + fprintf(stderr, "ERROR: Field %s is not unique.\n", name); + return 1; } } - } - free(tofree); - return NULL; -} - -char * check_streams(char * streams){ - char * stream; - int length, i, bad_streams; - - length = strlen(streams); - - stream = (char *)malloc(2*sizeof(char)); - stream[1] = '\0'; - - for (i = 0; i < length; i++){ - bad_streams = 1; - stream[0] = streams[i]; - if(strcmp(stream, "i") == 0 || strcmp(stream, "r") == 0 || strcmp(stream, "o") == 0 || strcmp(stream, "s") == 0){ - bad_streams = 0; - } - if (bad_streams == 1){ - return stream; - } + check_for_unique_names(registry, struct_xml); } - return NULL; -} - -int check_persistence(const char * persistence){ - if(strncmp(persistence, "persistent", 1024) == 0){ - return PERSISTENT; - } else if(strncmp(persistence, "scratch", 1024) == 0){ - return SCRATCH; - } else { - fprintf(stderr, "ERROR: In check_persistence. Persistence not equal to persistent or scratch.\n"); - return -1; - } -} + return 0; +}/*}}}*/ diff --git a/src/registry/registry_types.h b/src/registry/registry_types.h index fc080eae5b..5e2607ec07 100644 --- a/src/registry/registry_types.h +++ b/src/registry/registry_types.h @@ -10,6 +10,10 @@ #define LOGICAL 2 #define CHARACTER 3 +#define CELLS 0 +#define EDGES 1 +#define VERTICES 2 + #define PERSISTENT 0 #define SCRATCH 1 #define PACKAGE 2 @@ -19,76 +23,4 @@ #define OUTPUT0 0x00000004 #define SFC0 0x00000008 -#define NEW_NAMELIST(X) X = (struct namelist *)malloc(sizeof(struct namelist)); X->next = NULL; -#define NEW_DIMENSION(X) X = (struct dimension *)malloc(sizeof(struct dimension)); X->next = NULL; -#define NEW_DIMENSION_LIST(X) X = (struct dimension_list *)malloc(sizeof(struct dimension_list)); X->dim = NULL; X->prev = NULL; X->next = NULL; -#define NEW_VARIABLE(X) X = (struct variable *)malloc(sizeof(struct variable)); X->dimlist = NULL; X->next = NULL; X->package_name = NULL; -#define NEW_VARIABLE_LIST(X) X = (struct variable_list *)malloc(sizeof(struct variable_list)); X->var = NULL; X->prev = NULL; X->next = NULL; -#define NEW_GROUP_LIST(X) X = (struct group_list *)malloc(sizeof(struct group_list)); X->vlist = NULL; X->next = NULL; -#define NEW_PACKAGE(X) X = (struct package *)malloc(sizeof(struct package)); X->next = NULL; - -union default_val { - int ival; - float rval; - int lval; - char cval[32]; -}; - -struct namelist { - char name[1024]; - char record[1024]; - int vtype; - union default_val defval; - struct namelist * next; -}; - -struct dimension { - char name_in_file[1024]; - char name_in_code[1024]; - int constant_value; - int namelist_defined; - struct dimension * next; -}; - -struct dimension_list { - struct dimension * dim; - struct dimension_list * prev; - struct dimension_list * next; -}; - -struct variable_list { - struct variable * var; - struct variable_list * prev; - struct variable_list * next; -}; - -struct group_list { - char name[1024]; - struct package * package_name; - struct variable_list * vlist; - struct group_list * next; - int ntime_levs; -}; - -struct variable { - char name_in_file[1024]; - char name_in_code[1024]; - char struct_group[1024]; - char var_array[1024]; - char array_class[1024]; - char default_value[1024]; - struct package * package_name; - int persistence; - int vtype; - int ndims; - int timedim; - int iostreams; - int decomposed; - struct dimension_list * dimlist; - struct variable * next; -}; -struct package { - char name[1024]; - struct package * next; -}; diff --git a/src/registry/utility.c b/src/registry/utility.c new file mode 100644 index 0000000000..0bdcf092c0 --- /dev/null +++ b/src/registry/utility.c @@ -0,0 +1,265 @@ +// Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +// and the University Corporation for Atmospheric Research (UCAR). +// +// Unless noted otherwise source code is licensed under the BSD license. +// Additional copyright and license information can be found in the LICENSE file +// distributed with this code, or at http://mpas-dev.github.com/license.html +// + +#include +#include +#include +#include "ezxml/ezxml.h" +#include "registry_types.h" + +int is_derived_dim(char * d)/*{{{*/ +{ + if (strchr(d, (int)'+')) return 1; + if (strchr(d, (int)'-')) return 1; + + return 0; +}/*}}}*/ + + +char * new_dimension_name(char * old_name){/*{{{*/ + int i, j; + int len, new_len; + int new_string; + int added_sections; + int symbols; + char * new_name; + + i = 0; + new_string = 0; + added_sections = 0; + len = 0; + symbols = 0; + while (old_name[i] != '\0') { + if (new_string == 0 && ((old_name[i] >= 'a' && old_name[i] <= 'z') || (old_name[i] >= 'A' && old_name[i] <= 'Z'))){ + new_string = 1; + added_sections++; + } else if (old_name[i] == '+' || old_name[i] == '-' || old_name[i] == '*' || old_name[i] == '/'){ + new_string = 0; + symbols++; + } + len++; + i++; + } + + new_len = len + 7 + (added_sections-1) * 8 + symbols * 3 + 1; + new_name = malloc(sizeof(char)*new_len); + i = 0; + j = 0; + added_sections = 0; + while (old_name[i] != '\0') { + if (new_string == 0 && ((old_name[i] >= 'a' && old_name[i] <= 'z') || (old_name[i] >= 'A' && old_name[i] <= 'Z'))){ + new_string = 1; + if (added_sections == 0){ + new_name[j] = 'm'; + new_name[j+1] = 'e'; + new_name[j+2] = 's'; + new_name[j+3] = 'h'; + new_name[j+4] = ' '; + new_name[j+5] = '%'; + new_name[j+6] = ' '; + + j += 7; + } else { + new_name[j] = ' '; + new_name[j+1] = 'm'; + new_name[j+2] = 'e'; + new_name[j+3] = 's'; + new_name[j+4] = 'h'; + new_name[j+5] = ' '; + new_name[j+6] = '%'; + new_name[j+7] = ' '; + + j += 8; + } + + added_sections++; + } + if (old_name[i] == '+' || old_name[i] == '-' || old_name[i] == '*' || old_name[i] == '/'){ + new_string = 0; + new_name[j] = ' '; + + j++; + } + + new_name[j] = old_name[i]; + j++; + + if (old_name[i] == '+' || old_name[i] == '-' || old_name[i] == '*' || old_name[i] == '/'){ + new_string = 0; + new_name[j] = ' '; + + j++; + } + + i++; + } + + new_name[j] = '\0'; + + return new_name; +}/*}}}*/ + + +void split_derived_dim_string(char * dim, char ** p1, char ** p2)/*{{{*/ +{ + char * cp, * cm, * c; + int n; + + cp = strchr(dim, (int)'+'); + cm = strchr(dim, (int)'-'); + if (!cp) + c = cm; + else if (!cm) + c = cp; + else if (cm < cp) + c = cm; + else + c = cp; + + n = c - dim; + *p1 = (char *)malloc(n*sizeof(char)); + snprintf(*p1, n, "%s", dim+1); + + *p2 = (char *)malloc((strlen(dim)-n+1)*sizeof(char)); + sprintf(*p2, "%s", dim+n); +}/*}}}*/ + + +int is_integer_constant(char * c) {/*{{{*/ + int i; + + i = 0; + while (c[i] != '\0') { + if (c[i] < '0' || c[i] > '9') return -1; + i++; + } + + return atoi(c); +}/*}}}*/ + +char * check_packages(ezxml_t registry, char * packages){/*{{{*/ + ezxml_t packages_xml, package_xml; + + const char *packagename; + + char *string, *tofree, *token; + char *failed; + int missing_package; + + string = strdup(packages); + tofree = string; + failed = NULL; + + while( (token = strsep(&string, ";")) != NULL) { + missing_package = 1; + for (packages_xml = ezxml_child(registry, "packages"); packages_xml; packages_xml = packages_xml->next){ + for (package_xml = ezxml_child(packages_xml, "package"); package_xml; package_xml = package_xml->next){ + packagename = ezxml_attr(package_xml, "name"); + + if(strcasecmp(packagename, token) == 0){ + missing_package = 0; + } + } + } + + if (missing_package) { + failed = strdup(token); + free(tofree); + return failed; + } + } + free(tofree); + return failed; +}/*}}}*/ + +char * check_dimensions(ezxml_t registry, char * dims){/*{{{*/ + ezxml_t dims_xml, dim_xml; + + const char *dimname; + + char *string, *tofree, *token; + int missing_dim; + + string = strdup(dims); + tofree = string; + + while( (token = strsep(&string, " ")) != NULL) { + if (strcasecmp(token, "Time") != 0){ + missing_dim = 1; + for (dims_xml = ezxml_child(registry, "dims"); dims_xml; dims_xml = dims_xml->next){ + for (dim_xml = ezxml_child(dims_xml, "dim"); dim_xml; dim_xml = dim_xml->next){ + dimname = ezxml_attr(dim_xml, "name"); + + if(strcasecmp(dimname, token) == 0){ + missing_dim = 0; + } + } + } + + if (missing_dim) { + free(tofree); + return token; + } + } + } + free(tofree); + return NULL; +}/*}}}*/ + + +char * check_streams(ezxml_t registry, char * streams) +{ + ezxml_t streams_xml, stream_xml; + + const char *streamname; + + char *string, *tofree, *token; + char *failed; + int missing_stream; + + string = strdup(streams); + tofree = string; + failed = NULL; + + while( (token = strsep(&string, ";")) != NULL) { + missing_stream = 1; + for (streams_xml = ezxml_child(registry, "streams"); streams_xml; streams_xml = streams_xml->next) { + for (stream_xml = ezxml_child(streams_xml, "stream"); stream_xml; stream_xml = stream_xml->next) { + streamname = ezxml_attr(stream_xml, "name"); + + if(strcasecmp(streamname, token) == 0) { /* TODO: Not portable? */ + missing_stream = 0; + } + } + } + + if (missing_stream) { + failed = strdup(token); + free(tofree); + return failed; + } + } + free(tofree); + return failed; +} + + +int check_persistence(const char * persistence){/*{{{*/ + if(persistence){ + if(strncmp(persistence, "persistent", 1024) == 0){ + return PERSISTENT; + } else if(strncmp(persistence, "scratch", 1024) == 0){ + return SCRATCH; + } else { + fprintf(stderr, "ERROR: In check_persistence. Persistence not equal to persistent or scratch.\n"); + return -1; + } + } else { + return PERSISTENT; + } +}/*}}}*/ diff --git a/src/registry/utility.h b/src/registry/utility.h new file mode 100644 index 0000000000..37c9d0de27 --- /dev/null +++ b/src/registry/utility.h @@ -0,0 +1,17 @@ +// Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +// and the University Corporation for Atmospheric Research (UCAR). +// +// Unless noted otherwise source code is licensed under the BSD license. +// Additional copyright and license information can be found in the LICENSE file +// distributed with this code, or at http://mpas-dev.github.com/license.html +// + + +int is_derived_dim(char * d); +char * new_dimension_name(char * old_name); +void split_derived_dim_string(char * dim, char ** p1, char ** p2); +int is_integer_constant(char * c); +char * check_packages(ezxml_t registry, char * packages); +char * check_dimensions(ezxml_t registry, char * dims); +char * check_streams(ezxml_t registry, char * streams); +int check_persistence(const char * persistence);